Session Correctness_Algebras

Theory Base

(* Title:      Base
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Base›

theory Base

imports Stone_Relation_Algebras.Semirings

begin

class while =
  fixes while :: "'a  'a  'a" (infixr "" 59)

class n =
  fixes n :: "'a  'a"

class diamond =
  fixes diamond :: "'a  'a  'a" ("| _ > _" [50,90] 95)

class box =
  fixes box :: "'a  'a  'a" ("| _ ] _" [50,90] 95)

context ord
begin

definition ascending_chain :: "(nat  'a)  bool"
  where "ascending_chain f  n . f n  f (Suc n)"

definition descending_chain :: "(nat  'a)  bool"
  where "descending_chain f  n . f (Suc n)  f n"

definition directed :: "'a set  bool"
  where "directed X  X  {}  (xX . yX . zX . x  z  y  z)"

definition co_directed :: "'a set  bool"
  where "co_directed X  X  {}  (xX . yX . zX . z  x  z  y)"

definition chain :: "'a set  bool"
  where "chain X  xX . yX . x  y  y  x"

end

context order
begin

lemma ascending_chain_k:
  "ascending_chain f  f m  f (m + k)"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_isotone:
  "ascending_chain f  m  k  f m  f k"
  using lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_comparable:
  "ascending_chain f  f k  f m  f m  f k"
  by (meson ascending_chain_isotone linear)

lemma ascending_chain_chain:
  "ascending_chain f  chain (range f)"
  by (simp add: ascending_chain_comparable chain_def)

lemma chain_directed:
  "X  {}  chain X  directed X"
  by (metis chain_def directed_def)

lemma ascending_chain_directed:
  "ascending_chain f  directed (range f)"
  by (simp add: ascending_chain_chain chain_directed)

lemma descending_chain_k:
  "descending_chain f  f (m + k)  f m"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_antimono_le ord.descending_chain_def by blast

lemma descending_chain_antitone:
  "descending_chain f  m  k  f k  f m"
  using descending_chain_def lift_Suc_antimono_le by blast

lemma descending_chain_comparable:
  "descending_chain f  f k  f m  f m  f k"
  by (meson descending_chain_antitone nat_le_linear)

lemma descending_chain_chain:
  "descending_chain f  chain (range f)"
  by (simp add: descending_chain_comparable chain_def)

lemma chain_co_directed:
  "X  {}  chain X  co_directed X"
  by (metis chain_def co_directed_def)

lemma descending_chain_codirected:
  "descending_chain f  co_directed (range f)"
  by (simp add: chain_co_directed descending_chain_chain)

end

context semilattice_sup
begin

lemma ascending_chain_left_sup:
  "ascending_chain f  ascending_chain (λn . x  f n)"
  using ascending_chain_def sup_right_isotone by blast

lemma ascending_chain_right_sup:
  "ascending_chain f  ascending_chain (λn . f n  x)"
  using ascending_chain_def sup_left_isotone by auto

lemma descending_chain_left_add:
  "descending_chain f  descending_chain (λn . x  f n)"
  using descending_chain_def sup_right_isotone by blast

lemma descending_chain_right_add:
  "descending_chain f  descending_chain (λn . f n  x)"
  using descending_chain_def sup_left_isotone by auto

primrec pSum0 :: "(nat  'a)  nat  'a"
  where "pSum0 f 0 = f 0"
      | "pSum0 f (Suc m) = pSum0 f m  f m"

lemma pSum0_below:
 "i . f i  x  pSum0 f m  x"
  apply (induct m)
  by auto

end

context non_associative_left_semiring
begin

lemma ascending_chain_left_mult:
  "ascending_chain f  ascending_chain (λn . x * f n)"
  by (simp add: mult_right_isotone ord.ascending_chain_def)

lemma ascending_chain_right_mult:
  "ascending_chain f  ascending_chain (λn . f n * x)"
  by (simp add: mult_left_isotone ord.ascending_chain_def)

lemma descending_chain_left_mult:
  "descending_chain f  descending_chain (λn . x * f n)"
  by (simp add: descending_chain_def mult_right_isotone)

lemma descending_chain_right_mult:
  "descending_chain f  descending_chain (λn . f n * x)"
  by (simp add: descending_chain_def mult_left_isotone)

end

context complete_lattice
begin

lemma sup_Sup:
  "A  {}  sup x (Sup A) = Sup ((sup x) ` A)"
  apply (rule order.antisym)
  apply (meson ex_in_conv imageI SUP_upper2 Sup_mono sup.boundedI sup_left_divisibility sup_right_divisibility)
  by (meson SUP_least Sup_upper sup_right_isotone)

lemma sup_SUP:
  "Y  {}  sup x (SUP yY . f y) = (SUP yY. sup x (f y))"
  apply (subst sup_Sup)
  by (simp_all add: image_image)

lemma inf_Inf:
  "A  {}  inf x (Inf A) = Inf ((inf x) ` A)"
  apply (rule order.antisym)
  apply (meson INF_greatest Inf_lower inf.sup_right_isotone)
  by (simp add: INF_inf_const1)

lemma inf_INF:
  "Y  {}  inf x (INF yY . f y) = (INF yY. inf x (f y))"
  apply (subst inf_Inf)
  by (simp_all add: image_image)

lemma SUP_image_id[simp]:
  "(SUP xf`A . x) = (SUP xA . f x)"
  by simp

lemma INF_image_id[simp]:
  "(INF xf`A . x) = (INF xA . f x)"
  by simp

end

lemma image_Collect_2:
  "f ` { g x | x . P x } = { f (g x) | x . P x }"
  by auto

text ‹The following instantiation and four lemmas are from Jose Divason Mallagaray.›

instantiation "fun" :: (type, type) power
begin

definition one_fun :: "'a  'a"
  where one_fun_def: "one_fun  id"

definition times_fun :: "('a  'a)  ('a  'a)  ('a  'a)"
  where times_fun_def: "times_fun  comp"

instance
  by intro_classes

end

lemma id_power:
  "id^m = id"
  apply (induct m)
  apply (simp add: one_fun_def)
  by (simp add: times_fun_def)

lemma power_zero_id:
  "f^0 = id"
  by (simp add: one_fun_def)

lemma power_succ_unfold:
  "f^Suc m = f  f^m"
  by (simp add: times_fun_def)

lemma power_succ_unfold_ext:
  "(f^Suc m) x = f ((f^m) x)"
  by (simp add: times_fun_def)

end

Theory Omega_Algebras

(* Title:      Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Omega Algebras›

theory Omega_Algebras

imports Stone_Kleene_Relation_Algebras.Kleene_Algebras

begin

class omega =
  fixes omega :: "'a  'a" ("_ω" [100] 100)

class left_omega_algebra = left_kleene_algebra + omega +
  assumes omega_unfold: "yω = y * yω"
  assumes omega_induct: "x  z  y * x  x  yω  y * z"
begin

text ‹Many lemmas in this class are taken from Georg Struth's Isabelle theories.›

lemma star_bot_below_omega:
  "x * bot  xω"
  using omega_unfold star_left_induct_equal by auto

lemma star_bot_below_omega_bot:
  "x * bot  xω * bot"
  by (metis omega_unfold star_left_induct_equal sup_monoid.add_0_left mult_assoc)

lemma omega_induct_mult:
  "y  x * y  y  xω"
  by (metis bot_least omega_induct sup.absorb1 sup.absorb2 star_bot_below_omega)

lemma omega_sub_dist:
  "xω  (x  y)ω"
  by (metis eq_refl mult_isotone omega_unfold sup.cobounded1 omega_induct_mult)

lemma omega_isotone:
  "x  y  xω  yω"
  using sup_left_divisibility omega_sub_dist by fastforce

lemma omega_induct_equal:
  "y = z  x * y  y  xω  x * z"
  by (simp add: omega_induct)

lemma omega_bot:
  "botω = bot"
  by (metis mult_left_zero omega_unfold)

lemma omega_one_greatest:
  "x  1ω"
  by (simp add: omega_induct_mult)

lemma star_mult_omega:
  "x * xω = xω"
  by (metis order.antisym omega_unfold star.circ_loop_fixpoint star_left_induct_mult_equal sup.cobounded2)

lemma omega_sub_vector:
  "xω * y  xω"
  by (metis mult_semi_associative omega_unfold omega_induct_mult)

lemma omega_simulation:
  "z * x  y * z  z * xω  yω"
  by (smt (verit, ccfv_threshold) mult_isotone omega_unfold order_lesseq_imp mult_assoc omega_induct_mult)

lemma omega_omega:
  "xωω  xω"
  by (metis omega_unfold omega_sub_vector)

lemma left_plus_omega:
  "(x * x)ω = xω"
  by (metis order.antisym mult_assoc omega_induct_mult omega_unfold order_refl star.left_plus_circ star_mult_omega)

lemma omega_slide:
  "x * (y * x)ω = (x * y)ω"
  by (metis order.antisym mult_assoc mult_right_isotone omega_simulation omega_unfold order_refl)

lemma omega_simulation_2:
  "y * x  x * y  (x * y)ω  xω"
  by (metis mult_right_isotone sup.absorb2 omega_induct_mult omega_slide omega_sub_dist)

lemma wagner:
  "(x  y)ω = x * (x  y)ω  z  (x  y)ω = xω  x * z"
  by (smt (verit, ccfv_SIG) order.refl star_left_induct sup.absorb2 sup_assoc sup_commute omega_induct_equal omega_sub_dist)

lemma right_plus_omega:
  "(x * x)ω = xω"
  by (metis left_plus_omega omega_slide star_mult_omega)

lemma omega_sub_dist_1:
  "(x * y)ω  (x  y)ω"
  by (metis left_plus_omega mult_isotone star.circ_sub_dist sup.cobounded1 sup_monoid.add_commute omega_isotone)

lemma omega_sub_dist_2:
  "(x * y)ω  (x  y)ω"
  by (metis mult_isotone star.circ_sub_dist sup.cobounded2 omega_isotone right_plus_omega)

lemma omega_star:
  "(xω) = 1  xω"
  by (metis antisym_conv star.circ_mult_increasing star_left_unfold_equal omega_sub_vector)

lemma omega_mult_omega_star:
  "xω * xω = xω"
  by (simp add: order.antisym star.circ_mult_increasing omega_sub_vector)

lemma omega_sum_unfold_1:
  "(x  y)ω = xω  x * y * (x  y)ω"
  by (metis mult_right_dist_sup omega_unfold mult_assoc wagner)

lemma omega_sum_unfold_2:
  "(x  y)ω  (x * y)ω  (x * y) * xω"
  using omega_induct_equal omega_sum_unfold_1 by auto

lemma omega_sum_unfold_3:
  "(x * y) * xω  (x  y)ω"
  using star_left_induct_equal omega_sum_unfold_1 by auto

lemma omega_decompose:
  "(x  y)ω = (x * y)ω  (x * y) * xω"
  by (metis sup.absorb1 sup_same_context omega_sub_dist_2 omega_sum_unfold_2 omega_sum_unfold_3)

lemma omega_loop_fixpoint:
  "y * (yω  y * z)  z = yω  y * z"
  apply (rule order.antisym)
  apply (smt (verit, ccfv_threshold) eq_refl mult_isotone mult_left_sub_dist_sup omega_induct omega_unfold star.circ_loop_fixpoint sup_assoc sup_commute sup_right_isotone)
  by (smt (z3) mult_left_sub_dist_sup omega_unfold star.circ_loop_fixpoint sup.left_commute sup_commute sup_right_isotone)

lemma omega_loop_greatest_fixpoint:
  "y * x  z = x  x  yω  y * z"
  by (simp add: sup_commute omega_induct_equal)

lemma omega_square:
  "xω = (x * x)ω"
  using order.antisym omega_unfold order_refl mult_assoc omega_induct_mult omega_simulation_2 by auto

lemma mult_bot_omega:
  "(x * bot)ω = x * bot"
  by (metis mult_left_zero omega_slide)

lemma mult_bot_add_omega:
  "(x  y * bot)ω = xω  x * y * bot"
  by (metis mult_left_zero sup_commute mult_assoc mult_bot_omega omega_decompose omega_loop_fixpoint)

lemma omega_mult_star:
  "xω * x = xω"
  by (meson antisym_conv star.circ_back_loop_prefixpoint sup.boundedE omega_sub_vector)

lemma omega_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x  z) (yω  y * z)"
  by (simp add: is_greatest_fixpoint_def omega_loop_fixpoint omega_loop_greatest_fixpoint)

lemma omega_loop_nu:
  "ν (λx . y * x  z) = yω  y * z"
  by (metis greatest_fixpoint_same omega_loop_is_greatest_fixpoint)

lemma omega_loop_bot_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x) (yω)"
  using is_greatest_fixpoint_def omega_unfold omega_induct_mult by auto

lemma omega_loop_bot_nu:
  "ν (λx . y * x) = yω"
  by (metis greatest_fixpoint_same omega_loop_bot_is_greatest_fixpoint)

lemma affine_has_greatest_fixpoint:
  "has_greatest_fixpoint (λx . y * x  z)"
  using has_greatest_fixpoint_def omega_loop_is_greatest_fixpoint by blast

lemma omega_separate_unfold:
  "(x * y)ω = yω  y * x * (x * y)ω"
  by (metis star.circ_loop_fixpoint sup_commute mult_assoc omega_slide omega_sum_unfold_1)

lemma omega_bot_left_slide:
  "(x * y) * ((x * y)ω * bot  1) * x  x * (y * x) * ((y * x)ω * bot  1)"
proof -
  have "x  x * (y * x) * (y * x) * ((y * x)ω * bot  1)  x * (y * x) * ((y * x)ω * bot  1)"
    by (metis sup_commute mult_assoc mult_right_isotone star.circ_back_loop_prefixpoint star.mult_zero_sup_circ star.mult_zero_circ le_supE le_supI order.refl star.circ_increasing star.circ_mult_upper_bound)
  hence "((x * y)ω * bot  1) * x  x * y * (x * (y * x) * ((y * x)ω * bot  1))  x * (y * x) * ((y * x)ω * bot  1)"
    by (smt (z3) sup.absorb_iff2 sup_assoc mult_assoc mult_left_one mult_left_sub_dist_sup_left mult_left_zero mult_right_dist_sup omega_slide star_mult_omega)
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma omega_bot_add_1:
  "(x  y) * ((x  y)ω * bot  1) = x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
proof (rule order.antisym)
  have 1: "(x  y) * x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    by (smt (z3) eq_refl star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_sup_1 sup_assoc sup_commute mult_assoc)
  have 2: "1  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    using reflexive_mult_closed star.circ_reflexive sup_ge2 by auto
  have "(y * x)ω * bot  (y * x * (xω * bot  1))ω * bot"
    by (metis mult_1_right mult_left_isotone mult_left_sub_dist_sup_right omega_isotone)
  also have 3: "...  (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    by (metis mult_isotone mult_left_one star.circ_reflexive sup_commute sup_ge2)
  finally have 4: "(x * y)ω * bot  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    by (smt mult_assoc mult_right_isotone omega_slide)
  have "y * (x * y) * xω * bot  y * (x * (xω * bot  y)) * x * xω * bot * (y * x * (xω * bot  1))ω * bot"
    using mult_isotone mult_left_sub_dist_sup_left mult_left_zero order.refl star_isotone sup_commute mult_assoc star_mult_omega by auto
  also have "...  y * (x * (xω * bot  y)) * (x * (xω * bot  1) * y)ω * bot"
    by (smt mult_assoc mult_left_isotone mult_left_sub_dist_sup_left omega_slide)
  also have "... = y * (x * (xω * bot  1) * y)ω * bot"
    using mult_left_one mult_left_zero mult_right_dist_sup mult_assoc star_mult_omega by auto
  finally have "x * y * (x * y) * xω * bot  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    using 3 by (smt mult_assoc mult_right_isotone omega_slide order_trans)
  hence "(x * y) * xω * bot  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_one mult_1_right mult_right_sub_dist_sup_left order_trans star.circ_loop_fixpoint star.circ_reflexive star.mult_zero_circ)
  hence "(x  y)ω * bot  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    using 4 by (smt (z3) mult_right_dist_sup sup.orderE sup_assoc sup_right_divisibility omega_decompose)
  thus "(x  y) * ((x  y)ω * bot  1)  x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)"
    using 1 2 star_left_induct mult_assoc by force
next
  have 5: "xω * bot  (x  y) * ((x  y)ω * bot  1)"
    by (metis bot_least le_supI1 le_supI2 mult_isotone star.circ_loop_fixpoint sup.cobounded1 omega_isotone)
  have 6: "(y * x)ω * bot  (x  y) * ((x  y)ω * bot  1)"
    by (metis sup_commute mult_left_isotone omega_sub_dist_1 mult_assoc mult_left_sub_dist_sup_left order_trans star_mult_omega)
  have 7: "(y * x)  (x  y)"
    by (metis mult_left_one mult_right_sub_dist_sup_left star.circ_sup_1 star.circ_plus_one)
  hence "(y * x) * xω * bot  (x  y) * ((x  y)ω * bot  1)"
    by (smt sup_assoc le_iff_sup mult_assoc mult_isotone mult_right_dist_sup omega_sub_dist)
  hence "(xω * bot  y * x)ω * bot  (x  y) * ((x  y)ω * bot  1)"
    using 6 by (smt sup_commute sup.bounded_iff mult_assoc mult_right_dist_sup mult_bot_add_omega omega_unfold omega_bot)
  hence "(y * x * (xω * bot  1))ω * bot  y * x * (x  y) * ((x  y)ω * bot  1)"
    by (smt mult_assoc mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone omega_slide)
  also have "...  (x  y) * ((x  y)ω * bot  1)"
    using 7 by (metis mult_left_isotone order_refl star.circ_mult_upper_bound star_left_induct_mult_iff)
  finally have "(y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)  (x  y) * ((x  y)ω * bot  1)"
    using 5 by (smt (z3) le_supE star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_involutive star_isotone sup_commute)
  hence "(xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)  (x  y) * ((x  y)ω * bot  1)"
    using 5 by (metis sup_commute mult_assoc star.circ_isotone star.circ_mult_upper_bound star.mult_zero_sup_circ star.mult_zero_circ star_involutive)
  thus "x * (xω * bot  1) * (y * x * (xω * bot  1)) * ((y * x * (xω * bot  1))ω * bot  1)  (x  y) * ((x  y)ω * bot  1)"
    by (smt sup_assoc sup_commute mult_assoc star.circ_mult_upper_bound star.circ_sub_dist star.mult_zero_sup_circ star.mult_zero_circ)
qed

lemma star_omega_greatest:
  "xω = 1ω"
  by (metis sup_commute le_iff_sup omega_one_greatest omega_sub_dist star.circ_plus_one)

lemma omega_vector_greatest:
  "xω * 1ω = xω"
  by (metis order.antisym mult_isotone omega_mult_omega_star omega_one_greatest omega_sub_vector)

lemma mult_greatest_omega:
  "(x * 1ω)ω  x * 1ω"
  by (metis mult_right_isotone omega_slide omega_sub_vector)

lemma omega_mult_star_2:
  "xω * y = xω"
  by (meson order.antisym le_supE star.circ_back_loop_prefixpoint omega_sub_vector)

lemma omega_import:
  assumes "p  p * p"
      and "p * x  x * p"
    shows "p * xω = p * (p * x)ω"
proof -
  have "p * xω  p * (p * x) * xω"
    by (metis assms(1) mult_assoc mult_left_isotone omega_unfold)
  also have "...  p * x * p * xω"
    by (metis assms(2) mult_assoc mult_left_isotone mult_right_isotone)
  finally have "p * xω  (p * x)ω"
    by (simp add: mult_assoc omega_induct_mult)
  hence "p * xω  p * (p * x)ω"
    by (metis assms(1) mult_assoc mult_left_isotone mult_right_isotone order_trans)
  thus "p * xω = p * (p * x)ω"
    by (metis assms(2) sup_left_divisibility order.antisym mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)
qed

(*
lemma omega_circ_simulate_right_plus: "z * x ≤ y * (yω * bot ⊔ y) * z ⊔ w ⟶ z * (xω * bot ⊔ x) ≤ (yω * bot ⊔ y) * (z ⊔ w * (xω * bot ⊔ x))" nitpick [expect=genuine,card=4] oops
lemma omega_circ_simulate_left_plus: "x * z ≤ z * (yω * bot ⊔ y) ⊔ w ⟶ (xω * bot ⊔ x) * z ≤ (z ⊔ (xω * bot ⊔ x) * w) * (yω * bot ⊔ y)" nitpick [expect=genuine,card=5] oops
*)

end

text ‹Theorem 50.2›

sublocale left_omega_algebra < comb0: left_conway_semiring where circ = "(λx . x * (xω * bot  1))"
  apply unfold_locales
  apply (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_sub_dist_sup_left omega_unfold star.circ_loop_fixpoint star_mult_omega)
  using omega_bot_left_slide mult_assoc apply fastforce
  using omega_bot_add_1 mult_assoc by simp

class left_zero_omega_algebra = left_zero_kleene_algebra + left_omega_algebra
begin

lemma star_omega_absorb:
  "y * (y * x) * yω = (y * x) * yω"
proof -
  have "y * (y * x) * yω = y * y * x * (y * x) * yω  y * yω"
    by (metis sup_commute mult_assoc mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same)
  thus ?thesis
    by (metis mult_assoc star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
qed

lemma omega_circ_simulate_right_plus: 
  assumes "z * x  y * (yω * bot  y) * z  w"
    shows "z * (xω * bot  x)  (yω * bot  y) * (z  w * (xω * bot  x))"
proof -
  have 1: "z * x  yω * bot  y * y * z  w"
    by (metis assms mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold)
  hence "(yω * bot  y * z  y * w * xω * bot  y * w * x) * x  yω * bot  y * (yω * bot  y * y * z  w)  y * w * xω * bot  y * w * x"
    by (smt sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... = yω * bot  y * y * y * z  y * w * xω * bot  y * w * x"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_back_loop_fixpoint star_mult_omega)
  also have "...  yω * bot  y * z  y * w * xω * bot  y * w * x"
    by (smt sup_commute sup_left_isotone mult_left_isotone star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have "z  (yω * bot  y * z  y * w * xω * bot  y * w * x) * x  yω * bot  y * z  y * w * xω * bot  y * w * x"
    by (metis (no_types, lifting) le_supE le_supI star.circ_loop_fixpoint sup.cobounded1)
  hence 2: "z * x  yω * bot  y * z  y * w * xω * bot  y * w * x"
    by (simp add: star_right_induct)
  have "z * xω * bot  (yω * bot  y * y * z  w) * xω * bot"
    using 1 by (smt sup_left_divisibility mult_assoc mult_right_sub_dist_sup_left omega_unfold)
  hence "z * xω * bot  yω  y * (yω * bot  w * xω * bot)"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_zero mult_right_dist_sup omega_induct star.left_plus_circ)
  thus "z * (xω * bot  x)  (yω * bot  y) * (z  w * (xω * bot  x))"
    using 2 by (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold omega_bot star_mult_omega zero_right_mult_decreasing)
qed

lemma omega_circ_simulate_left_plus:
  assumes "x * z  z * (yω * bot  y)  w"
    shows "(xω * bot  x) * z  (z  (xω * bot  x) * w) * (yω * bot  y)"
proof -
  have "x * (z * yω * bot  z * y  xω * bot  x * w * yω * bot  x * w * y) = x * z * yω * bot  x * z * y  xω * bot  x * x * w * yω * bot  x * x * w * y"
    by (smt mult_assoc mult_left_dist_sup omega_unfold)
  also have "...  x * z * yω * bot  x * z * y  xω * bot  x * w * yω * bot  x * w * y"
    by (metis sup_mono sup_right_isotone mult_left_isotone star.left_plus_below_circ)
  also have "...  (z * yω * bot  z * y  w) * yω * bot  (z * yω * bot  z * y  w) * y  xω * bot  x * w * yω * bot  x * w * y"
    by (metis assms sup_left_isotone mult_assoc mult_left_dist_sup mult_left_isotone)
  also have "... = z * yω * bot  z * y * yω * bot  w * yω * bot  z * yω * bot  z * y * y  w * y  xω * bot  x * w * yω * bot  x * w * y"
    by (smt sup_assoc mult_assoc mult_left_zero mult_right_dist_sup)
  also have "... = z * yω * bot  z * y  xω * bot  x * w * yω * bot  x * w * y"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
  finally have "x * z  z * yω * bot  z * y  xω * bot  x * w * yω * bot  x * w * y"
    by (smt (z3) le_supE sup_least sup_ge1 star.circ_back_loop_fixpoint star_left_induct)
  hence "(xω * bot  x) * z  z * yω * bot  z * y  xω * bot  x * w * yω * bot  x * w * y"
    by (smt (z3) sup.left_commute sup_commute sup_least sup_ge1 mult_assoc mult_left_zero mult_right_dist_sup)
  thus "(xω * bot  x) * z  (z  (xω * bot  x) * w) * (yω * bot  y)"
    by (smt sup_assoc mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup)
qed

lemma omega_translate:
  "x * (xω * bot  1) = xω * bot  x"
  by (metis mult_assoc mult_left_dist_sup mult_1_right star_mult_omega)

lemma omega_circ_simulate_right:
  assumes "z * x  y * z  w"
    shows "z * (xω * bot  x)  (yω * bot  y) * (z  w * (xω * bot  x))"
proof -
  have "...  y * (yω * bot  y) * z  w"
    using comb0.circ_mult_increasing mult_isotone sup_left_isotone omega_translate by auto
  thus "z * (xω * bot  x)  (yω * bot  y) * (z  w * (xω * bot  x))"
    using assms order_trans omega_circ_simulate_right_plus by blast
qed

end

sublocale left_zero_omega_algebra < comb1: left_conway_semiring_1 where circ = "(λx . x * (xω * bot  1))"
  apply unfold_locales
  by (smt order.eq_iff mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup mult_1_right omega_slide star_slide)

sublocale left_zero_omega_algebra < comb0: itering where circ = "(λx . x * (xω * bot  1))"
  apply unfold_locales
  using comb1.circ_sup_9 apply blast
  using comb1.circ_mult_1 apply blast
  apply (metis omega_circ_simulate_right_plus omega_translate)
  using omega_circ_simulate_left_plus omega_translate by auto

text ‹Theorem 2.2›

sublocale left_zero_omega_algebra < comb2: itering where circ = "(λx . xω * bot  x)"
  apply unfold_locales
  using comb1.circ_sup_9 omega_translate apply force
  apply (metis comb1.circ_mult_1 omega_translate)
  using omega_circ_simulate_right_plus apply blast
  by (simp add: omega_circ_simulate_left_plus)

class omega_algebra = kleene_algebra + left_zero_omega_algebra

class left_omega_conway_semiring = left_omega_algebra + left_conway_semiring
begin

subclass left_kleene_conway_semiring ..

lemma circ_below_omega_star:
  "x  xω  x"
  by (metis circ_left_unfold mult_1_right omega_induct order_refl)

lemma omega_mult_circ:
  "xω * x = xω"
  by (metis circ_star omega_mult_star_2)

lemma circ_mult_omega:
  "x * xω = xω"
  by (metis order.antisym sup_right_divisibility circ_loop_fixpoint circ_plus_sub omega_simulation)

lemma circ_omega_greatest:
  "xω = 1ω"
  by (metis circ_star star_omega_greatest)

lemma omega_circ:
  "xω = 1  xω"
  by (metis order.antisym circ_left_unfold mult_left_sub_dist_sup_left mult_1_right omega_sub_vector)

end

class bounded_left_omega_algebra = bounded_left_kleene_algebra + left_omega_algebra
begin

lemma omega_one:
  "1ω = top"
  by (simp add: order.antisym omega_one_greatest)

lemma star_omega_top:
  "xω = top"
  by (simp add: star_omega_greatest omega_one)

lemma omega_vector:
  "xω * top = xω"
  by (simp add: order.antisym omega_sub_vector top_right_mult_increasing)

lemma mult_top_omega:
  "(x * top)ω  x * top"
  using mult_greatest_omega omega_one by auto

end

sublocale bounded_left_omega_algebra < comb0: bounded_left_conway_semiring where circ = "(λx . x * (xω * bot  1))" ..

class bounded_left_zero_omega_algebra = bounded_left_zero_kleene_algebra + left_zero_omega_algebra
begin

subclass bounded_left_omega_algebra ..

end

sublocale bounded_left_zero_omega_algebra < comb0: bounded_itering where circ = "(λx . x * (xω * bot  1))" ..

class bounded_omega_algebra = bounded_kleene_algebra + omega_algebra
begin

subclass bounded_left_zero_omega_algebra ..

end

class bounded_left_omega_conway_semiring = bounded_left_omega_algebra + left_omega_conway_semiring
begin

subclass left_kleene_conway_semiring ..

subclass bounded_left_conway_semiring ..

lemma circ_omega:
  "xω = top"
  by (simp add: circ_omega_greatest omega_one)

end

class top_left_omega_algebra = bounded_left_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_3:
  "x * (xω * bot  1) = x * (xω  1)"
  by (metis omega_one omega_vector_greatest top_left_bot mult_assoc)

end

text ‹Theorem 50.2›

sublocale top_left_omega_algebra < comb4: left_conway_semiring where circ = "(λx . x * (xω  1))"
  apply unfold_locales
  using comb0.circ_left_unfold omega_translate_3 apply force
  using omega_bot_left_slide omega_translate_3 mult_assoc apply force
  using comb0.circ_sup_1 omega_translate_3 by auto

class top_left_bot_omega_algebra = bounded_left_zero_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_2:
  "xω * bot  x = xω  x"
  by (metis mult_assoc omega_mult_star_2 star.circ_top top_left_bot)

end

text ‹Theorem 2.3›

sublocale top_left_bot_omega_algebra < comb3: itering where circ = "(λx . xω  x)"
  apply unfold_locales
  using comb2.circ_slide_1 comb2.circ_sup_1 omega_translate_2 apply force
  apply (metis comb2.circ_mult_1 omega_translate_2)
  using omega_circ_simulate_right_plus omega_translate_2 apply force
  using omega_circ_simulate_left_plus omega_translate_2 by auto

class Omega =
  fixes Omega :: "'a  'a" ("_Ω" [100] 100)

end

Theory Capped_Omega_Algebras

(* Title:      Capped Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Capped Omega Algebras›

theory Capped_Omega_Algebras

imports Omega_Algebras

begin

class capped_omega =
  fixes capped_omega :: "'a  'a  'a" ("_ω_" [100,100] 100)

class capped_omega_algebra = bounded_left_zero_kleene_algebra + bounded_distrib_lattice + capped_omega +
  assumes capped_omega_unfold: "yωv = y * yωv  v"
  assumes capped_omega_induct: "x  (y * x  z)  v  x  yωv  y * z"

text ‹AACP Theorem 6.1›

notation
  top ("")

sublocale capped_omega_algebra < capped: bounded_left_zero_omega_algebra where omega = "(λy . yω)"
  apply unfold_locales
  apply (metis capped_omega_unfold inf_top_right)
  by (simp add: capped_omega_induct sup_commute)

context capped_omega_algebra
begin

text ‹AACP Theorem 6.2›

lemma capped_omega_below_omega:
  "yωv  yω"
  using capped.omega_induct_mult capped_omega_unfold order.eq_iff by force

text ‹AACP Theorem 6.3›

lemma capped_omega_below:
  "yωv  v"
  using capped_omega_unfold order.eq_iff by force

text ‹AACP Theorem 6.4›

lemma capped_omega_one:
  "1ωv = v"
proof -
  have "v  (1 * v  bot)  v"
    by simp
  hence "v  1ωv  1 * bot"
    by (simp add: capped_omega_induct)
  also have "... = 1ωv"
    by (simp add: star_one)
  finally show ?thesis
    by (simp add: capped_omega_below order.antisym)
qed

text ‹AACP Theorem 6.5›

lemma capped_omega_zero:
  "botωv = bot"
  by (metis capped_omega_below_omega bot_unique capped.omega_bot)

lemma star_below_cap:
  "y  u  z  v  u * v  v  y * z  v"
  by (metis le_sup_iff order.trans mult_left_isotone star_left_induct)

lemma capped_fix:
  assumes "y  u"
      and "z  v"
      and "u * v  v"
    shows "(y * (yωv  y * z)  z)  v = yωv  y * z"
proof -
  have "(y * (yωv  y * z)  z)  v = (y * yωv  y * z)  v"
    by (simp add: mult_left_dist_sup star.circ_loop_fixpoint sup_assoc)
  also have "... = (y * yωv  v)  (y * z  v)"
    by (simp add: inf_sup_distrib2)
  also have "... = yωv  y * z"
    using assms capped_omega_unfold le_iff_inf star_below_cap by auto
  finally show ?thesis
    .
qed

lemma capped_fixpoint:
  "y  u  z  v  u * v  v  is_fixpoint (λx . (y * x  z)  v) (yωv  y * z)"
  by (simp add: capped_fix is_fixpoint_def)

lemma capped_greatest_fixpoint:
  "y  u  z  v  u * v  v  is_greatest_fixpoint (λx . (y * x  z)  v) (yωv  y * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_fixpoint_def)

lemma capped_postfixpoint:
  "y  u  z  v  u * v  v  is_postfixpoint (λx . (y * x  z)  v) (yωv  y * z)"
  using capped_fix inf.eq_refl is_postfixpoint_def by auto

lemma capped_greatest_postfixpoint:
  "y  u  z  v  u * v  v  is_greatest_postfixpoint (λx . (y * x  z)  v) (yωv  y * z)"
  by (smt capped_fix order_refl capped_omega_induct is_greatest_postfixpoint_def)

text ‹AACP Theorem 6.6›

lemma capped_nu:
  "y  u  z  v  u * v  v  ν(λx . (y * x  z)  v) = yωv  y * z"
  by (metis capped_greatest_fixpoint greatest_fixpoint_same)

lemma capped_pnu:
  "y  u  z  v  u * v  v  (λx . (y * x  z)  v) = yωv  y * z"
  by (metis capped_greatest_postfixpoint greatest_postfixpoint_same)

text ‹AACP Theorem 6.7›

lemma unfold_capped_omega:
  "y  u  u * v  v  y * yωv = yωv"
  by (smt (verit, ccfv_SIG) capped_omega_below capped_omega_unfold inf.order_lesseq_imp le_iff_inf mult_isotone)

text ‹AACP Theorem 6.8›

lemma star_mult_capped_omega:
  assumes "y  u"
      and "u * v  v"
    shows "y * yωv = yωv"
proof -
  have "y * yωv = yωv"
    using assms unfold_capped_omega by auto
  hence "y * yωv  yωv"
    by (simp add: star_left_induct_mult)
  thus ?thesis
    by (metis sup_ge2 order.antisym star.circ_loop_fixpoint)
qed

text ‹AACP Theorem 6.9›

lemma star_zero_below_capped_omega_zero:
  assumes "y  u"
      and "u * v  v"
    shows "y * bot  yωv * bot"
proof -
  have "y * yωv  v"
    using assms capped_omega_below unfold_capped_omega by auto
  hence "y * yωv = yωv"
    using assms unfold_capped_omega by auto
  thus ?thesis
    by (metis bot_least eq_refl mult_assoc star_below_cap)
qed

lemma star_zero_below_capped_omega:
  "y  u  u * v  v  y * bot  yωv"
  by (simp add: star_loop_least_fixpoint unfold_capped_omega)

lemma capped_omega_induct_meet_zero:
  "x  y * x  v  x  yωv  y * bot"
  by (simp add: capped_omega_induct)

text ‹AACP Theorem 6.10›

lemma capped_omega_induct_meet:
  "y  u  u * v  v  x  y * x  v  x  yωv"
  by (metis capped_omega_induct_meet_zero sup_commute le_iff_sup star_zero_below_capped_omega)

lemma capped_omega_induct_equal:
  "x = (y * x  z)  v  x  yωv  y * z"
  using capped_omega_induct inf.le_iff_sup by auto

text ‹AACP Theorem 6.11›

lemma capped_meet_nu:
  assumes "y  u"
      and "u * v  v"
    shows "ν(λx . y * x  v) = yωv"
proof -
  have "yωv  y * bot = yωv"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "ν(λx . (y * x  bot)  v) = yωv"
    by (metis assms capped_nu bot_least)
  thus ?thesis
    by simp
qed

lemma capped_meet_pnu:
  assumes "y  u"
      and "u * v  v"
    shows "(λx . y * x  v) = yωv"
proof -
  have "yωv  y * bot = yωv"
    by (smt assms star_zero_below_capped_omega le_iff_sup sup_commute)
  hence "(λx . (y * x  bot)  v) = yωv"
    by (metis assms capped_pnu bot_least)
  thus ?thesis
    by simp
qed

text ‹AACP Theorem 6.12›

lemma capped_omega_isotone:
  "y  u  u * v  v  t  y  tωv  yωv"
  by (metis capped_omega_induct_meet capped_omega_unfold le_iff_sup inf.sup_left_isotone mult_right_sub_dist_sup_left)

text ‹AACP Theorem 6.13›

lemma capped_omega_simulation:
  assumes "y  u"
      and "s  u"
      and "u * v  v"
      and "s * t  y * s"
    shows "s * tωv  yωv"
proof -
  have "s * tωv  s * t * tωv  s * v"
    by (metis capped_omega_below capped_omega_unfold inf.boundedI inf.cobounded1 mult_right_isotone mult_assoc)
  also have "...  s * t * tωv  v"
    using assms(2,3) inf.order_lesseq_imp inf.sup_right_isotone mult_left_isotone by blast
  also have "...  y * s * tωv  v"
    using assms(4) inf.sup_left_isotone mult_left_isotone by auto
  finally show ?thesis
    using assms(1,3) capped_omega_induct_meet mult_assoc by auto
qed

lemma capped_omega_slide_sub:
  assumes "s  u"
      and "y  u"
      and "u * u  u"
      and "u * v  v"
    shows "s * (y * s)ωv  (s * y)ωv"
proof -
  have "s * y  u"
    by (meson assms(1-3) mult_isotone order_trans)
  thus ?thesis
    using assms(1,4) capped_omega_simulation mult_assoc by auto 
qed

text ‹AACP Theorem 6.14›

lemma capped_omega_slide:
  "s  u  y  u  u * u  u  u * v  v  s * (y * s)ωv = (s * y)ωv"
  by (smt (verit) order.antisym mult_assoc mult_right_isotone capped_omega_unfold capped_omega_slide_sub inf.sup_ge1 order_trans)

lemma capped_omega_sub_dist:
  "s  u  y  u  u * v  v  sωv  (s  y)ωv"
  by (simp add: capped_omega_isotone)

text ‹AACP Theorem 6.15›

lemma capped_omega_simulation_2:
  assumes "s  u"
      and "y  u"
      and "u * u  u"
      and "u * v  v"
      and "y * s  s * y"
    shows "(s * y)ωv  sωv"
proof -
  have 1: "s * y  u"
    using assms(1-3) inf.order_lesseq_imp mult_isotone by blast
  have 2: "s * (s * y)ωv  v"
    by (meson assms(1,4) capped_omega_below order.trans mult_isotone)
  have "(s * y)ωv = s * (y * s)ωv"
    using assms(1-4) capped_omega_slide by auto
  also have "...  s * (s * y)ωv"
    using 1 assms(4,5) capped_omega_isotone mult_right_isotone by blast
  also have "... = s * (s * y)ωv  v"
    using 2 inf.order_iff by auto
  finally show ?thesis
    using assms(1,4) capped_omega_induct_meet by blast
qed

text ‹AACP Theorem 6.16›

lemma left_plus_capped_omega:
  assumes "y  u"
      and "u * u  u"
      and "u * v  v"
    shows "(y * y)ωv = yωv"
proof -
  have 1: "y * y  u"
    by (metis assms(1,2) star_plus star_below_cap)
  hence "y * y * (y * y)ωv  v"
    using assms(3) capped_omega_below unfold_capped_omega by auto
  hence "y * y * (y * y)ωv = (y * y)ωv"
    using 1 assms(3) unfold_capped_omega by blast
  hence "(y * y)ωv  yωv"
    using 1 by (smt assms(1,3) capped_omega_simulation mult_assoc mult_semi_associative star.circ_transitive_equal star_simulation_right_equal)
  thus ?thesis
    using 1 by (meson assms(3) capped_omega_isotone order.antisym star.circ_mult_increasing)
qed

text ‹AACP Theorem 6.17›

lemma capped_omega_sub_vector:
  assumes "z  v"
      and "y  u"
      and "u * v  v"
    shows "yωu * z  yωv"
proof -
  have "yωu * z  y * yωu * z  u * z"
    by (metis capped_omega_below capped_omega_unfold eq_refl inf.boundedI inf.cobounded1 mult_isotone)
  also have "...  y * yωu * z  v"
    by (metis assms(1,3) inf.sup_left_isotone inf_commute mult_right_isotone order_trans)
  finally show ?thesis
    using assms(2,3) capped_omega_induct_meet mult_assoc by auto
qed

text ‹AACP Theorem 6.18›

lemma capped_omega_omega:
  "y  u  u * v  v  (yωu)ωv  yωv"
  by (metis capped_omega_below capped_omega_sub_vector unfold_capped_omega)

end

end

Theory General_Refinement_Algebras

(* Title:      General Refinement Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹General Refinement Algebras›

theory General_Refinement_Algebras

imports Omega_Algebras

begin

class general_refinement_algebra = left_kleene_algebra + Omega +
  assumes Omega_unfold: "yΩ  1  y * yΩ"
  assumes Omega_induct: "x  z  y * x  x  yΩ * z"
begin

lemma Omega_unfold_equal:
  "yΩ = 1  y * yΩ"
  by (smt Omega_induct Omega_unfold sup_right_isotone order.antisym mult_right_isotone mult_1_right)

lemma Omega_sup_1:
  "(x  y)Ω = xΩ * (y * xΩ)Ω"
  apply (rule order.antisym)
  apply (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute sup_right_isotone mult_assoc mult_right_dist_sup mult_right_isotone mult_1_right order_refl)
  by (smt Omega_induct Omega_unfold_equal sup_assoc sup_commute mult_assoc mult_left_one mult_right_dist_sup mult_1_right order_refl)

lemma Omega_left_slide:
  "(x * y)Ω * x  x * (y * x)Ω"
proof -
  have "1  y * (x * y)Ω * x  1  y * x * (1  (y * (x * y)Ω) * x)"
    by (smt Omega_unfold_equal sup_right_isotone mult_assoc mult_left_one mult_left_sub_dist_sup mult_right_dist_sup mult_right_isotone mult_1_right)
  thus ?thesis
    by (smt Omega_induct Omega_unfold_equal le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)
qed

end

text ‹Theorem 50.3›

sublocale general_refinement_algebra < Omega: left_conway_semiring where circ = Omega
  apply unfold_locales
  using Omega_unfold_equal apply simp
  apply (simp add: Omega_left_slide)
  by (simp add: Omega_sup_1)

context general_refinement_algebra
begin

lemma star_below_Omega:
  "x  xΩ"
  by (metis Omega_induct mult_1_right order_refl star.circ_left_unfold)

lemma star_mult_Omega:
  "xΩ = x * xΩ"
  by (metis Omega.left_plus_below_circ sup_commute sup_ge1 order.eq_iff star.circ_loop_fixpoint star_left_induct_mult_iff)

lemma Omega_one_greatest:
  "x  1Ω"
  by (metis Omega_induct sup_bot_left mult_left_one order_refl order_trans zero_right_mult_decreasing)

lemma greatest_left_zero:
  "1Ω * x = 1Ω"
  by (simp add: Omega_one_greatest Omega_induct order.antisym)

(*
lemma circ_right_unfold: "1 ⊔ xΩ * x = xΩ" nitpick [expect=genuine,card=8] oops
lemma circ_slide: "(x * y)Ω * x = x * (y * x)Ω" nitpick [expect=genuine,card=6] oops
lemma circ_simulate: "z * x ≤ y * z ⟹ z * xΩ ≤ yΩ * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right: "z * x ≤ y * z ⊔ w ⟹ z * xΩ ≤ yΩ * (z ⊔ w * xΩ)" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_1: "z * x ≤ y * z ⟹ z * xΩ ≤ yΩ * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_plus: "z * x ≤ y * yΩ * z ⊔ w ⟹ z * xΩ ≤ yΩ * (z ⊔ w * xΩ)" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_right_plus_1: "z * x ≤ y * yΩ * z ⟹ z * xΩ ≤ yΩ * z" nitpick [expect=genuine,card=6] oops
lemma circ_simulate_left_1: "x * z ≤ z * y ⟹ xΩ * z ≤ z * yΩ ⊔ xΩ * bot" oops (* holds in LKA, counterexample exists in GRA *)
lemma circ_simulate_left_plus_1: "x * z ≤ z * yΩ ⟹ xΩ * z ≤ z * yΩ ⊔ xΩ * bot" oops (* holds in LKA, counterexample exists in GRA *)
lemma circ_simulate_absorb: "y * x ≤ x ⟹ yΩ * x ≤ x ⊔ yΩ * bot" nitpick [expect=genuine,card=8] oops (* holds in LKA, counterexample exists in GRA *)
*)

end

class bounded_general_refinement_algebra = general_refinement_algebra + bounded_left_kleene_algebra
begin

lemma Omega_one:
  "1Ω = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by blast

end

sublocale bounded_general_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class left_demonic_refinement_algebra = general_refinement_algebra +
  assumes Omega_isolate: "yΩ  yΩ * bot  y"
begin

lemma Omega_isolate_equal:
  "yΩ = yΩ * bot  y"
  using Omega_isolate order.antisym le_sup_iff star_below_Omega zero_right_mult_decreasing by auto

(*
lemma Omega_sum_unfold_1: "(x ⊔ y)Ω = yΩ ⊔ y * x * (x ⊔ y)Ω" oops
lemma Omega_sup_3: "(x ⊔ y)Ω = (x * y)Ω * xΩ" oops
*)

end

class bounded_left_demonic_refinement_algebra = left_demonic_refinement_algebra + bounded_left_kleene_algebra
begin

(*
lemma Omega_mult: "(x * y)Ω = 1 ⊔ x * (y * x)Ω * y" oops
lemma Omega_sup: "(x ⊔ y)Ω = (xΩ * y)Ω * xΩ" oops
lemma Omega_simulate: "z * x ≤ y * z ⟹ z * xΩ ≤ yΩ * z" nitpick [expect=genuine,card=6] oops
lemma Omega_separate_2: "y * x ≤ x * (x ⊔ y) ⟹ (x ⊔ y)Ω = xΩ * yΩ" oops
lemma Omega_circ_simulate_right_plus: "z * x ≤ y * yΩ * z ⊔ w ⟹ z * xΩ ≤ yΩ * (z ⊔ w * xΩ)" nitpick [expect=genuine,card=6] oops
lemma Omega_circ_simulate_left_plus: "x * z ≤ z * yΩ ⊔ w ⟹ xΩ * z ≤ (z ⊔ xΩ * w) * yΩ" oops
*)

end

sublocale bounded_left_demonic_refinement_algebra < Omega: bounded_left_conway_semiring where circ = Omega ..

class demonic_refinement_algebra = left_zero_kleene_algebra + left_demonic_refinement_algebra
begin

lemma Omega_mult:
  "(x * y)Ω = 1  x * (y * x)Ω * y"
  by (smt (verit, del_insts) Omega.circ_left_slide Omega_induct Omega_unfold_equal order.eq_iff mult_assoc mult_left_dist_sup mult_1_right)

lemma Omega_sup:
  "(x  y)Ω = (xΩ * y)Ω * xΩ"
  by (smt Omega_sup_1 Omega_mult mult_assoc mult_left_dist_sup mult_left_one mult_right_dist_sup mult_1_right)

lemma Omega_simulate:
  "z * x  y * z  z * xΩ  yΩ * z"
  by (smt Omega_induct Omega_unfold_equal sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone mult_1_right)

end

text ‹Theorem 2.4›

sublocale demonic_refinement_algebra < Omega1: itering_1 where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_simulate mult_assoc)
  by (simp add: Omega_simulate)

sublocale demonic_refinement_algebra < Omega1: left_zero_conway_semiring_1 where circ = Omega ..

context demonic_refinement_algebra
begin

lemma Omega_sum_unfold_1:
  "(x  y)Ω = yΩ  y * x * (x  y)Ω"
  by (smt Omega1.circ_sup_9 Omega.circ_loop_fixpoint Omega_isolate_equal sup_assoc sup_commute mult_assoc mult_left_zero mult_right_dist_sup)

lemma Omega_sup_3:
  "(x  y)Ω = (x * y)Ω * xΩ"
  apply (rule order.antisym)
  apply (metis Omega_sum_unfold_1 Omega_induct eq_refl sup_commute)
  by (simp add: Omega.circ_isotone Omega_sup mult_left_isotone star_below_Omega)

lemma Omega_separate_2:
  "y * x  x * (x  y)  (x  y)Ω = xΩ * yΩ"
  apply (rule order.antisym)
  apply (smt (verit, del_insts) Omega_induct Omega_sum_unfold_1 sup_right_isotone mult_assoc mult_left_isotone star_mult_Omega star_simulation_left)
  by (simp add: Omega.circ_sub_dist_3)

lemma Omega_circ_simulate_right_plus:
  assumes "z * x  y * yΩ * z  w"
    shows "z * xΩ  yΩ * (z  w * xΩ)"
proof -
  have "z * xΩ = z  z * x * xΩ"
    using Omega1.circ_back_loop_fixpoint Omega1.circ_plus_same sup_commute mult_assoc by auto
  also have "...  y * yΩ * z * xΩ  z  w * xΩ"
    by (smt assms sup_assoc sup_commute sup_right_isotone le_iff_sup mult_right_dist_sup)
  finally have "z * xΩ  (y * yΩ)Ω * (z  w * xΩ)"
    by (smt Omega_induct sup_assoc sup_commute mult_assoc)
  thus ?thesis
    by (simp add: Omega.left_plus_circ)
qed

lemma Omega_circ_simulate_left_plus:
  assumes "x * z  z * yΩ  w"
    shows "xΩ * z  (z  xΩ * w) * yΩ"
proof -
  have "x * ((z  xΩ * w) * yΩ)  (z * yΩ  w  x * xΩ * w) * yΩ"
    by (smt assms mult_assoc mult_left_dist_sup sup_left_isotone mult_left_isotone)
  also have "...  z * yΩ * yΩ  w * yΩ  xΩ * w * yΩ"
    by (smt Omega.left_plus_below_circ sup_right_isotone mult_left_isotone mult_right_dist_sup)
  finally have 1: "x * ((z  xΩ * w) * yΩ)  (z  xΩ * w) * yΩ"
    by (metis Omega.circ_transitive_equal mult_assoc Omega.circ_reflexive sup_assoc le_iff_sup mult_left_one mult_right_dist_sup)
  have "xΩ * z  = xΩ * bot  x * z"
    by (metis Omega_isolate_equal mult_assoc mult_left_zero mult_right_dist_sup)
  also have "...  xΩ * w * yΩ  x * (z  xΩ * w) * yΩ"
    by (metis Omega1.circ_back_loop_fixpoint bot_least idempotent_bot_closed le_supI2 mult_isotone mult_left_sub_dist_sup_left semiring.add_mono zero_right_mult_decreasing mult_assoc)
  also have "...  (z  xΩ * w) * yΩ"
    using 1 by (metis le_supI mult_right_sub_dist_sup_right star_left_induct_mult mult_assoc)
  finally show ?thesis
    .
qed

lemma Omega_circ_simulate_right:
  assumes "z * x  y * z  w"
    shows "z * xΩ  yΩ * (z  w * xΩ)"
proof -
  have "y * z  w  y * yΩ * z  w"
    using Omega.circ_mult_increasing mult_left_isotone sup_left_isotone by auto
  thus ?thesis
    using Omega_circ_simulate_right_plus assms order.trans by blast
qed

end

sublocale demonic_refinement_algebra < Omega: itering where circ = Omega
  apply unfold_locales
  apply (simp add: Omega_sup)
  using Omega_mult apply blast
  apply (simp add: Omega_circ_simulate_right_plus)
  using Omega_circ_simulate_left_plus by auto

class bounded_demonic_refinement_algebra = demonic_refinement_algebra + bounded_left_zero_kleene_algebra
begin

lemma Omega_one:
  "1Ω = top"
  by (simp add: Omega_one_greatest order.antisym)

lemma top_left_zero:
  "top * x = top"
  using Omega_one greatest_left_zero by auto

end

sublocale bounded_demonic_refinement_algebra < Omega: bounded_itering where circ = Omega ..

class general_refinement_algebra_omega = left_omega_algebra + Omega +
  assumes omega_left_zero: "xω  xω * y"
  assumes Omega_def: "xΩ = xω  x"
begin

lemma omega_left_zero_equal:
  "xω * y = xω"
  by (simp add: order.antisym omega_left_zero omega_sub_vector)

subclass left_demonic_refinement_algebra
  apply unfold_locales
  apply (metis Omega_def sup_commute eq_refl mult_1_right omega_loop_fixpoint)
  apply (metis Omega_def mult_right_dist_sup omega_induct omega_left_zero_equal)
  by (metis Omega_def mult_right_sub_dist_sup_right sup_commute sup_right_isotone omega_left_zero_equal)

end

class left_demonic_refinement_algebra_omega = bounded_left_omega_algebra + Omega +
  assumes top_left_zero: "top * x = top"
  assumes Omega_def: "xΩ = xω  x"
begin

subclass general_refinement_algebra_omega
  apply unfold_locales
  apply (metis mult_assoc omega_vector order_refl top_left_zero)
  by (rule Omega_def)

end

class demonic_refinement_algebra_omega = left_demonic_refinement_algebra_omega + bounded_left_zero_omega_algebra
begin

lemma Omega_mult:
  "(x * y)Ω = 1  x * (y * x)Ω * y"
  by (metis Omega_def comb1.circ_mult_1 omega_left_zero_equal omega_translate)

lemma Omega_sup:
  "(x  y)Ω = (xΩ * y)Ω * xΩ"
proof -
  have "(xΩ * y)Ω * xΩ = (x * y) * xω  (x * y)ω  (x * y) * xω * xΩ"
    by (smt sup_commute Omega_def mult_assoc mult_right_dist_sup mult_bot_add_omega omega_left_zero_equal star.circ_sup_1)
  thus ?thesis
    using Omega_def Omega_sup_1 comb2.circ_slide_1 omega_left_zero_equal by auto
qed

lemma Omega_simulate:
  "z * x  y * z  z * xΩ  yΩ * z"
  using Omega_def comb2.circ_simulate omega_left_zero_equal by auto

subclass demonic_refinement_algebra ..

end

(*
text hold in GRA and LKA
lemma circ_circ_mult: "1Ω * xΩ = xΩΩ" oops
lemma sub_mult_one_circ: "x * 1Ω ≤ 1Ω * x" oops
lemma circ_circ_mult_1: "xΩ * 1Ω = xΩΩ" oops
lemma "y * x ≤ x ⟹ y * x ≤ 1 * x" oops

text unknown
lemma circ_simulate_2: "y * xΩ ≤ xΩ * yΩ ⟷ yΩ * xΩ ≤ xΩ * yΩ" oops (* holds in LKA *)
lemma circ_simulate_3: "y * xΩ ≤ xΩ ⟹ yΩ * xΩ ≤ xΩ * yΩ" oops (* holds in LKA *)
lemma circ_separate_mult_1: "y * x ≤ x * y ⟹ (x * y)Ω ≤ xΩ * yΩ" oops
lemma "x = (x * x) * (x ⊔ 1)" oops
lemma "y * x ≤ x * y ⟹ (x ⊔ y) = x * y" oops
lemma "y * x ≤ (1 ⊔ x) * y ⟹ (x ⊔ y) = x * y" oops
*)

end

Theory Lattice_Ordered_Semirings

(* Title:      Lattice-Ordered Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Lattice-Ordered Semirings›

theory Lattice_Ordered_Semirings

imports Stone_Relation_Algebras.Semirings

begin

text ‹Many results in this theory are taken from a joint paper with Rudolf Berghammer.›

text ‹M0-algebra›

class lattice_ordered_pre_left_semiring = pre_left_semiring + bounded_distrib_lattice
begin

subclass bounded_pre_left_semiring
  apply unfold_locales
  by simp

lemma top_mult_right_one:
  "x * top = x * top * 1"
  by (metis order.antisym mult_sub_right_one mult_sup_associative_one surjective_one_closed)

lemma mult_left_sub_dist_inf_left:
  "x * (y  z)  x * y"
  by (simp add: mult_right_isotone)

lemma mult_left_sub_dist_inf_right:
  "x * (y  z)  x * z"
  by (simp add: mult_right_isotone)

lemma mult_right_sub_dist_inf_left:
  "(x  y) * z  x * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_inf_right:
  "(x  y) * z  y * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_inf:
  "(x  y) * z  x * z  y * z"
  by (simp add: mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right)

text ‹Figure 1: fundamental properties›

definition co_total          :: "'a  bool" where "co_total x  x * bot = bot"
definition up_closed         :: "'a  bool" where "up_closed x  x * 1 = x"
definition sup_distributive  :: "'a  bool" where "sup_distributive x  (y z . x * (y  z) = x * y  x * z)"
definition inf_distributive  :: "'a  bool" where "inf_distributive x  (y z . x * (y  z) = x * y  x * z)"
definition contact           :: "'a  bool" where "contact x  x * x  1 = x"
definition kernel            :: "'a  bool" where "kernel x  x * x  1 = x * 1"
definition sup_dist_contact  :: "'a  bool" where "sup_dist_contact x  sup_distributive x  contact x"
definition inf_dist_kernel   :: "'a  bool" where "inf_dist_kernel x  inf_distributive x  kernel x"
definition test              :: "'a  bool" where "test x  x * top  1 = x"
definition co_test           :: "'a  bool" where "co_test x  x * bot  1 = x"
definition co_vector         :: "'a  bool" where "co_vector x  x * bot = x"

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma reflexive_total:
  "reflexive x  total x"
  using sup_left_divisibility total_sup_closed by force

lemma reflexive_dense:
  "reflexive x  dense_rel x"
  using mult_left_isotone by fastforce

lemma reflexive_transitive_up_closed:
  "reflexive x  transitive x  up_closed x"
  by (metis antisym_conv mult_isotone mult_sub_right_one reflexive_dense up_closed_def)

lemma coreflexive_co_total:
  "coreflexive x  co_total x"
  by (metis co_total_def order.eq_iff mult_left_isotone mult_left_one bot_least)

lemma coreflexive_transitive:
  "coreflexive x  transitive x"
  by (simp add: coreflexive_transitive)

lemma idempotent_transitive_dense:
  "idempotent x  transitive x  dense_rel x"
  by (simp add: order.eq_iff)

lemma contact_reflexive:
  "contact x  reflexive x"
  using contact_def sup_right_divisibility by auto

lemma contact_transitive:
  "contact x  transitive x"
  using contact_def sup_left_divisibility by blast

lemma contact_dense:
  "contact x  dense_rel x"
  by (simp add: contact_reflexive reflexive_dense)

lemma contact_idempotent:
  "contact x  idempotent x"
  by (simp add: contact_dense contact_transitive idempotent_transitive_dense)

lemma contact_up_closed:
  "contact x  up_closed x"
  by (simp add: contact_reflexive contact_transitive reflexive_transitive_up_closed)

lemma contact_reflexive_idempotent_up_closed:
  "contact x  reflexive x  idempotent x  up_closed x"
  by (metis contact_def contact_idempotent contact_reflexive contact_up_closed sup_absorb2 sup_monoid.add_commute)

lemma kernel_coreflexive:
  "kernel x  coreflexive x"
  by (metis kernel_def inf.boundedE mult_sub_right_one)

lemma kernel_transitive:
  "kernel x  transitive x"
  by (simp add: coreflexive_transitive kernel_coreflexive)

lemma kernel_dense:
  "kernel x  dense_rel x"
  by (metis kernel_def inf.boundedE mult_sub_right_one)

lemma kernel_idempotent:
  "kernel x  idempotent x"
  by (simp add: idempotent_transitive_dense kernel_dense kernel_transitive)

lemma kernel_up_closed:
  "kernel x  up_closed x"
  by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)

lemma kernel_coreflexive_idempotent_up_closed:
  "kernel x  coreflexive x  idempotent x  up_closed x"
  by (metis kernel_coreflexive kernel_def kernel_idempotent inf.absorb1 up_closed_def)

lemma test_coreflexive:
  "test x  coreflexive x"
  using inf.sup_right_divisibility test_def by blast

lemma test_up_closed:
  "test x  up_closed x"
  by (metis order.eq_iff mult_left_one mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one up_closed_def)

lemma co_test_reflexive:
  "co_test x  reflexive x"
  using co_test_def sup_right_divisibility by blast

lemma co_test_transitive:
  "co_test x  transitive x"
  by (smt co_test_def sup_assoc le_iff_sup mult_left_one mult_left_zero mult_right_dist_sup mult_semi_associative)

lemma co_test_idempotent:
  "co_test x  idempotent x"
  by (simp add: co_test_reflexive co_test_transitive idempotent_transitive_dense reflexive_dense)

lemma co_test_up_closed:
  "co_test x  up_closed x"
  by (simp add: co_test_reflexive co_test_transitive reflexive_transitive_up_closed)

lemma co_test_contact:
  "co_test x  contact x"
  by (simp add: co_test_idempotent co_test_reflexive co_test_up_closed contact_reflexive_idempotent_up_closed)

lemma vector_transitive:
  "vector x  transitive x"
  by (metis mult_right_isotone top.extremum)

lemma vector_up_closed:
  "vector x  up_closed x"
  by (metis top_mult_right_one up_closed_def)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹total›

lemma one_total:
  "total 1"
  by simp

lemma top_total:
  "total top"
  by simp

lemma sup_total:
  "total x  total y  total (x  y)"
  by (simp add: total_sup_closed)

text ‹co-total›

lemma zero_co_total:
  "co_total bot"
  by (simp add: co_total_def)

lemma one_co_total:
  "co_total 1"
  by (simp add: co_total_def)

lemma sup_co_total:
  "co_total x  co_total y  co_total (x  y)"
  by (simp add: co_total_def mult_right_dist_sup)

lemma inf_co_total:
  "co_total x  co_total y  co_total (x  y)"
  by (metis co_total_def order.antisym bot_least mult_right_sub_dist_inf_right)

lemma comp_co_total:
  "co_total x  co_total y  co_total (x * y)"
  by (metis co_total_def order.eq_iff mult_semi_associative bot_least)

text ‹sub-transitive›

lemma zero_transitive:
  "transitive bot"
  by (simp add: vector_transitive)

lemma one_transitive:
  "transitive 1"
  by simp

lemma top_transitive:
  "transitive top"
  by simp

lemma inf_transitive:
  "transitive x  transitive y  transitive (x  y)"
  by (meson inf_mono order_trans mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right mult_right_sub_dist_inf)

text ‹dense›

lemma zero_dense:
  "dense_rel bot"
  by simp

lemma one_dense:
  "dense_rel 1"
  by simp

lemma top_dense:
  "dense_rel top"
  by simp

lemma sup_dense:
  assumes "dense_rel x"
      and "dense_rel y"
    shows "dense_rel (x  y)"
proof -
  have "x  x * x  y  y * y"
    using assms by auto
  hence "x  (x  y) * (x  y)  y  (x  y) * (x  y)"
    by (meson dense_sup_closed order_trans sup.cobounded1 sup.cobounded2)
  hence "x  y  (x  y) * (x  y)"
    by simp
  thus "dense_rel (x  y)"
    by simp
qed

text ‹reflexive›

lemma one_reflexive:
  "reflexive 1"
  by simp

lemma top_reflexive:
  "reflexive top"
  by simp

lemma sup_reflexive:
  "reflexive x  reflexive y  reflexive (x  y)"
  by (simp add: reflexive_sup_closed)

lemma inf_reflexive:
  "reflexive x  reflexive y  reflexive (x  y)"
  by simp

lemma comp_reflexive:
  "reflexive x  reflexive y  reflexive (x * y)"
  using reflexive_mult_closed by auto

text ‹co-reflexive›

lemma zero_coreflexive:
  "coreflexive bot"
  by simp

lemma one_coreflexive:
  "coreflexive 1"
  by simp

lemma sup_coreflexive:
  "coreflexive x  coreflexive y  coreflexive (x  y)"
  by simp

lemma inf_coreflexive:
  "coreflexive x  coreflexive y  coreflexive (x  y)"
  by (simp add: le_infI1)

lemma comp_coreflexive:
  "coreflexive x  coreflexive y  coreflexive (x * y)"
  by (simp add: coreflexive_mult_closed)

text ‹idempotent›

lemma zero_idempotent:
  "idempotent bot"
  by simp

lemma one_idempotent:
  "idempotent 1"
  by simp

lemma top_idempotent:
  "idempotent top"
  by simp

text ‹up-closed›

lemma zero_up_closed:
  "up_closed bot"
  by (simp add: up_closed_def)

lemma one_up_closed:
  "up_closed 1"
  by (simp add: up_closed_def)

lemma top_up_closed:
  "up_closed top"
  by (simp add: vector_up_closed)

lemma sup_up_closed:
  "up_closed x  up_closed y  up_closed (x  y)"
  by (simp add: mult_right_dist_sup up_closed_def)

lemma inf_up_closed:
  "up_closed x  up_closed y  up_closed (x  y)"
  by (metis order.antisym mult_sub_right_one mult_right_sub_dist_inf up_closed_def)

lemma comp_up_closed:
  "up_closed x  up_closed y  up_closed (x * y)"
  by (metis order.antisym mult_semi_associative mult_sub_right_one up_closed_def)

text ‹add-distributive›

lemma zero_sup_distributive:
  "sup_distributive bot"
  by (simp add: sup_distributive_def)

lemma one_sup_distributive:
  "sup_distributive 1"
  by (simp add: sup_distributive_def)

lemma sup_sup_distributive:
  "sup_distributive x  sup_distributive y  sup_distributive (x  y)"
  using sup_distributive_def mult_right_dist_sup sup_monoid.add_assoc sup_monoid.add_commute by auto

text ‹inf-distributive›

lemma zero_inf_distributive:
  "inf_distributive bot"
  by (simp add: inf_distributive_def)

lemma one_inf_distributive:
  "inf_distributive 1"
  by (simp add: inf_distributive_def)

text ‹contact›

lemma one_contact:
  "contact 1"
  by (simp add: contact_def)

lemma top_contact:
  "contact top"
  by (simp add: contact_def)

lemma inf_contact:
  "contact x  contact y  contact (x  y)"
  by (meson contact_reflexive_idempotent_up_closed contact_transitive inf_reflexive inf_transitive inf_up_closed preorder_idempotent)

text ‹kernel›

lemma zero_kernel:
  "kernel bot"
  by (simp add: kernel_def)

lemma one_kernel:
  "kernel 1"
  by (simp add: kernel_def)

lemma sup_kernel:
  "kernel x  kernel y  kernel (x  y)"
  using kernel_coreflexive_idempotent_up_closed order.antisym coreflexive_transitive sup_dense sup_up_closed by force

text ‹add-distributive contact›

lemma one_sup_dist_contact:
  "sup_dist_contact 1"
  by (simp add: sup_dist_contact_def one_sup_distributive one_contact)

text ‹inf-distributive kernel›

lemma zero_inf_dist_kernel:
  "inf_dist_kernel bot"
  by (simp add: inf_dist_kernel_def zero_kernel zero_inf_distributive)

lemma one_inf_dist_kernel:
  "inf_dist_kernel 1"
  by (simp add: inf_dist_kernel_def one_kernel one_inf_distributive)

text ‹test›

lemma zero_test:
  "test bot"
  by (simp add: test_def)

lemma one_test:
  "test 1"
  by (simp add: test_def)

lemma sup_test:
  "test x  test y  test (x  y)"
  by (simp add: inf_sup_distrib2 mult_right_dist_sup test_def)

lemma inf_test:
  "test x  test y  test (x  y)"
  by (smt (z3) inf.left_commute idempotent_one_closed inf.le_iff_sup inf_top.right_neutral mult_right_isotone mult_sub_right_one mult_right_sub_dist_inf test_def top_mult_right_one)

text ‹co-test›

lemma one_co_test:
  "co_test 1"
  by (simp add: co_test_def)

lemma sup_co_test:
  "co_test x  co_test y  co_test (x  y)"
  by (smt (z3) co_test_def mult_right_dist_sup sup.left_idem sup_assoc sup_commute)

text ‹vector›

lemma zero_vector:
  "vector bot"
  by simp

lemma top_vector:
  "vector top"
  by simp

lemma sup_vector:
  "vector x  vector y  vector (x  y)"
  by (simp add: vector_sup_closed)

lemma inf_vector:
  "vector x  vector y  vector (x  y)"
  by (metis order.antisym top_right_mult_increasing mult_right_sub_dist_inf)

lemma comp_vector:
  "vector y  vector (x * y)"
  by (simp add: vector_mult_closed)

end

class lattice_ordered_pre_left_semiring_1 = non_associative_left_semiring + bounded_distrib_lattice +
  assumes mult_associative_one: "x * (y * z) = (x * (y * 1)) * z"
  assumes mult_right_dist_inf_one: "(x * 1  y * 1) * z = x * z  y * z"
begin

subclass pre_left_semiring
  apply unfold_locales
  by (metis mult_associative_one mult_left_isotone mult_right_isotone mult_sub_right_one)

subclass lattice_ordered_pre_left_semiring ..

lemma mult_zero_associative:
  "x * bot * y = x * bot"
  by (metis mult_associative_one mult_left_zero)

lemma mult_zero_sup_one_dist:
  "(x * bot  1) * z = x * bot  z"
  by (simp add: mult_right_dist_sup mult_zero_associative)

lemma mult_zero_sup_dist:
  "(x * bot  y) * z = x * bot  y * z"
  by (simp add: mult_right_dist_sup mult_zero_associative)

lemma vector_zero_inf_one_comp:
  "(x * bot  1) * y = x * bot  y"
  by (metis mult_left_one mult_right_dist_inf_one mult_zero_associative)

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma co_test_inf_distributive:
  "co_test x  inf_distributive x"
  by (metis co_test_def distrib_imp1 inf_sup_distrib1 inf_distributive_def mult_zero_sup_one_dist)

lemma co_test_sup_distributive:
  "co_test x  sup_distributive x"
  by (metis sup_sup_distributive sup_distributive_def co_test_def one_sup_distributive sup.idem mult_zero_associative)

lemma co_test_sup_dist_contact:
  "co_test x  sup_dist_contact x"
  by (simp add: co_test_sup_distributive sup_dist_contact_def co_test_contact)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹co-test›

lemma inf_co_test:
  "co_test x  co_test y  co_test (x  y)"
  by (smt (z3) co_test_def co_test_up_closed mult_right_dist_inf_one sup_commute sup_inf_distrib1 up_closed_def)

lemma comp_co_test:
  "co_test x  co_test y  co_test (x * y)"
  by (metis co_test_def mult_associative_one sup_assoc mult_zero_sup_one_dist)

end

class lattice_ordered_pre_left_semiring_2 = lattice_ordered_pre_left_semiring +
  assumes mult_sub_associative_one: "x * (y * z)  (x * (y * 1)) * z"
  assumes mult_right_dist_inf_one_sub: "x * z  y * z  (x * 1  y * 1) * z"
begin

subclass lattice_ordered_pre_left_semiring_1
  apply unfold_locales
  apply (simp add: order.antisym mult_sub_associative_one mult_sup_associative_one)
  by (metis order.eq_iff mult_one_associative mult_right_dist_inf_one_sub mult_right_sub_dist_inf)

end

class multirelation_algebra_1 = lattice_ordered_pre_left_semiring +
  assumes mult_left_top: "top * x = top"
begin

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma top_sup_distributive:
  "sup_distributive top"
  by (simp add: sup_distributive_def mult_left_top)

lemma top_inf_distributive:
  "inf_distributive top"
  by (simp add: inf_distributive_def mult_left_top)

lemma top_sup_dist_contact:
  "sup_dist_contact top"
  by (simp add: sup_dist_contact_def top_contact top_sup_distributive)

lemma top_co_test:
  "co_test top"
  by (simp add: co_test_def mult_left_top)

end

text ‹M1-algebra›

class multirelation_algebra_2 = multirelation_algebra_1 + lattice_ordered_pre_left_semiring_2
begin

lemma mult_top_associative:
  "x * top * y = x * top"
  by (metis mult_left_top mult_associative_one)

lemma vector_inf_one_comp:
  "(x * top  1) * y = x * top  y"
  by (metis vector_zero_inf_one_comp mult_top_associative)

lemma vector_left_annihilator:
  "vector x  x * y = x"
  by (metis mult_top_associative)

text ‹properties›

lemma test_comp_inf:
  "test x  test y  x * y = x  y"
  by (metis inf.absorb1 inf.left_commute test_coreflexive test_def vector_inf_one_comp)

text ‹AAMP Theorem 6 / Figure 2: relations between properties›

lemma test_sup_distributive:
  "test x  sup_distributive x"
  by (metis sup_distributive_def inf_sup_distrib1 test_def vector_inf_one_comp)

lemma test_inf_distributive:
  "test x  inf_distributive x"
  by (smt (verit, ccfv_SIG) inf.commute inf.sup_monoid.add_assoc inf_distributive_def test_def inf.idem vector_inf_one_comp)

lemma test_inf_dist_kernel:
  "test x  inf_dist_kernel x"
  by (simp add: kernel_def inf_dist_kernel_def one_test test_comp_inf test_inf_distributive)

lemma vector_idempotent:
  "vector x  idempotent x"
  using vector_left_annihilator by blast

lemma vector_sup_distributive:
  "vector x  sup_distributive x"
  by (simp add: sup_distributive_def vector_left_annihilator)

lemma vector_inf_distributive:
  "vector x  inf_distributive x"
  by (simp add: inf_distributive_def vector_left_annihilator)

lemma vector_co_vector:
  "vector x  co_vector x"
  by (metis co_vector_def mult_zero_associative mult_top_associative)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹test›

lemma comp_test:
  "test x  test y  test (x * y)"
  by (simp add: inf_test test_comp_inf)

end

class dual =
  fixes dual :: "'a  'a" ("_d" [100] 100)

class multirelation_algebra_3 = lattice_ordered_pre_left_semiring + dual +
  assumes dual_involutive: "xdd = x"
  assumes dual_dist_sup: "(x  y)d = xd  yd"
  assumes dual_one: "1d = 1"
begin

lemma dual_dist_inf:
  "(x  y)d = xd  yd"
  by (metis dual_dist_sup dual_involutive)

lemma dual_antitone:
  "x  y  yd  xd"
  using dual_dist_sup sup_right_divisibility by fastforce

lemma dual_zero:
  "botd = top"
  by (metis dual_antitone bot_least dual_involutive top_le)

lemma dual_top:
  "topd = bot"
  using dual_zero dual_involutive by auto

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma reflexive_coreflexive_dual:
  "reflexive x  coreflexive (xd)"
  using dual_antitone dual_involutive dual_one by fastforce

end

class multirelation_algebra_4 = multirelation_algebra_3 +
  assumes dual_sub_dist_comp: "(x * y)d  xd * yd"
begin

subclass multirelation_algebra_1
  apply unfold_locales
  by (metis order.antisym top.extremum dual_zero dual_sub_dist_comp dual_involutive mult_left_zero)

lemma dual_sub_dist_comp_one:
  "(x * y)d  (x * 1)d * yd"
  by (metis dual_sub_dist_comp mult_one_associative)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

lemma co_total_total_dual:
  "co_total x  total (xd)"
  by (metis co_total_def dual_sub_dist_comp dual_zero top_le)

lemma transitive_dense_dual:
  "transitive x  dense_rel (xd)"
  using dual_antitone dual_sub_dist_comp inf.order_lesseq_imp by blast

end

text ‹M2-algebra›

class multirelation_algebra_5 = multirelation_algebra_3 +
  assumes dual_dist_comp_one: "(x * y)d = (x * 1)d * yd"
begin

subclass multirelation_algebra_4
  apply unfold_locales
  by (metis dual_antitone mult_sub_right_one mult_left_isotone dual_dist_comp_one)

lemma strong_up_closed:
  "x * 1  x  xd * yd  (x * y)d"
  by (simp add: dual_dist_comp_one antisym_conv mult_sub_right_one)

lemma strong_up_closed_2:
  "up_closed x  (x * y)d = xd * yd"
  by (simp add: dual_dist_comp_one up_closed_def)

subclass lattice_ordered_pre_left_semiring_2
  apply unfold_locales
  apply (smt comp_up_closed dual_antitone dual_dist_comp_one dual_involutive dual_one mult_left_one mult_one_associative mult_semi_associative up_closed_def strong_up_closed_2)
  by (smt dual_dist_comp_one dual_dist_inf dual_involutive eq_refl mult_one_associative mult_right_dist_sup)

text ‹AAMP Theorem 8›

subclass multirelation_algebra_2 ..

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹up-closed›

lemma dual_up_closed:
  "up_closed x  up_closed (xd)"
  by (metis dual_involutive dual_one up_closed_def strong_up_closed_2)

text ‹contact›

lemma contact_kernel_dual:
  "contact x  kernel (xd)"
  by (metis contact_def contact_up_closed dual_dist_sup dual_involutive dual_one kernel_def kernel_up_closed up_closed_def strong_up_closed_2)

text ‹add-distributive contact›

lemma sup_dist_contact_inf_dist_kernel_dual:
  "sup_dist_contact x  inf_dist_kernel (xd)"
proof
  assume 1: "sup_dist_contact x"
  hence 2: "up_closed x"
    using sup_dist_contact_def contact_up_closed by auto
  have "sup_distributive x"
    using 1 sup_dist_contact_def by auto
  hence "inf_distributive (xd)"
    using 2 by (smt sup_distributive_def dual_dist_comp_one dual_dist_inf dual_involutive inf_distributive_def up_closed_def)
  thus "inf_dist_kernel (xd)"
    using 1 contact_kernel_dual sup_dist_contact_def inf_dist_kernel_def by blast
next
  assume 3: "inf_dist_kernel (xd)"
  hence 4: "up_closed (xd)"
    using kernel_up_closed inf_dist_kernel_def by auto
  have "inf_distributive (xd)"
    using 3 inf_dist_kernel_def by auto
  hence "sup_distributive (xdd)"
    using 4 by (smt inf_distributive_def sup_distributive_def dual_dist_sup dual_involutive strong_up_closed_2)
  thus "sup_dist_contact x"
    using 3 contact_kernel_dual sup_dist_contact_def dual_involutive inf_dist_kernel_def by auto
qed

text ‹test›

lemma test_co_test_dual:
  "test x  co_test (xd)"
  by (smt (z3) co_test_def co_test_up_closed dual_dist_comp_one dual_dist_inf dual_involutive dual_one dual_top test_def test_up_closed up_closed_def)

text ‹vector›

lemma vector_dual:
  "vector x  vector (xd)"
  by (metis dual_dist_comp_one dual_involutive mult_top_associative)

end

class multirelation_algebra_6 = multirelation_algebra_4 +
  assumes dual_sub_dist_comp_one: "(x * 1)d * yd  (x * y)d"
begin

subclass multirelation_algebra_5
  apply unfold_locales
  by (metis dual_sub_dist_comp dual_sub_dist_comp_one order.eq_iff mult_one_associative)

(*
lemma "dense_rel x ∧ coreflexive x ⟶ up_closed x" nitpick [expect=genuine,card=5] oops
lemma "x * top ⊓ y * z ≤ (x * top ⊓ y) * z" nitpick [expect=genuine,card=8] oops
*)

end

text ‹M3-algebra›

class up_closed_multirelation_algebra = multirelation_algebra_3 +
  assumes dual_dist_comp: "(x * y)d = xd * yd"
begin

lemma mult_right_dist_inf:
  "(x  y) * z = x * z  y * z"
  by (metis dual_dist_sup dual_dist_comp dual_involutive mult_right_dist_sup)

text ‹AAMP Theorem 9›

subclass idempotent_left_semiring
  apply unfold_locales
  apply (metis order.antisym dual_antitone dual_dist_comp dual_involutive mult_semi_associative)
  apply simp
  by (metis order.antisym dual_antitone dual_dist_comp dual_involutive dual_one mult_sub_right_one)

subclass multirelation_algebra_6
  apply unfold_locales
  by (simp_all add: dual_dist_comp)

lemma vector_inf_comp:
  "(x * top  y) * z = x * top  y * z"
  by (simp add: vector_left_annihilator mult_right_dist_inf mult.assoc)

lemma vector_zero_inf_comp:
  "(x * bot  y) * z = x * bot  y * z"
  by (simp add: mult_right_dist_inf mult.assoc)

text ‹AAMP Theorem 10 / Figure 3: closure properties›

text ‹total›

lemma inf_total:
  "total x  total y  total (x  y)"
  by (simp add: mult_right_dist_inf)

lemma comp_total:
  "total x  total y  total (x * y)"
  by (simp add: mult_assoc)

lemma total_co_total_dual:
  "total x  co_total (xd)"
  by (metis co_total_def dual_dist_comp dual_involutive dual_top)

text ‹dense›

lemma transitive_iff_dense_dual:
  "transitive x  dense_rel (xd)"
  by (metis dual_antitone dual_dist_comp dual_involutive)

text ‹idempotent›

lemma idempotent_dual:
  "idempotent x  idempotent (xd)"
  using dual_involutive idempotent_transitive_dense transitive_iff_dense_dual by auto

text ‹add-distributive›

lemma comp_sup_distributive:
  "sup_distributive x  sup_distributive y  sup_distributive (x * y)"
  by (simp add: sup_distributive_def mult.assoc)

lemma sup_inf_distributive_dual:
  "sup_distributive x  inf_distributive (xd)"
  by (smt (verit, ccfv_threshold) sup_distributive_def dual_dist_sup dual_dist_comp dual_dist_inf dual_involutive inf_distributive_def)

text ‹inf-distributive›

lemma inf_inf_distributive:
  "inf_distributive x  inf_distributive y  inf_distributive (x  y)"
  by (metis sup_inf_distributive_dual sup_sup_distributive dual_dist_inf dual_involutive)

lemma comp_inf_distributive:
  "inf_distributive x  inf_distributive y  inf_distributive (x * y)"
  by (simp add: inf_distributive_def mult.assoc)

(*
lemma "co_total x ∧ transitive x ∧ up_closed x ⟶ coreflexive x" nitpick [expect=genuine,card=5] oops
lemma "total x ∧ dense_rel x ∧ up_closed x ⟶ reflexive x" nitpick [expect=genuine,card=5] oops
lemma "x * top ⊓ xd * bot = bot" nitpick [expect=genuine,card=6] oops
*)

end

class multirelation_algebra_7 = multirelation_algebra_4 +
  assumes vector_inf_comp: "(x * top  y) * z = x * top  y * z"
begin

lemma vector_zero_inf_comp:
  "(x * bot  y) * z = x * bot  y * z"
  by (metis vector_inf_comp vector_mult_closed zero_vector)

lemma test_sup_distributive:
  "test x  sup_distributive x"
  by (metis sup_distributive_def inf_sup_distrib1 mult_left_one test_def vector_inf_comp)

lemma test_inf_distributive:
  "test x  inf_distributive x"
  by (smt (z3) inf.right_idem inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_distributive_def mult_left_one test_def vector_inf_comp)

lemma test_inf_dist_kernel:
  "test x  inf_dist_kernel x"
  by (metis inf.idem inf.sup_monoid.add_assoc kernel_def inf_dist_kernel_def mult_left_one test_def test_inf_distributive vector_inf_comp)

lemma co_test_inf_distributive:
  assumes "co_test x"
    shows "inf_distributive x"
proof -
  have "x = x * bot  1"
    using assms co_test_def by auto
  hence "y z . x * y  x * z = x * (y  z)"
    by (metis distrib_imp1 inf_sup_absorb inf_sup_distrib1 mult_left_one mult_left_top mult_right_dist_sup sup_top_right vector_zero_inf_comp)
  thus "inf_distributive x"
    by (simp add: inf_distributive_def)
qed

lemma co_test_sup_distributive:
  assumes "co_test x"
    shows "sup_distributive x"
proof -
  have "x = x * bot  1"
    using assms co_test_def by auto
  hence "y z . x * (y  z) = x * y  x * z"
    by (metis sup_sup_distributive sup_distributive_def inf_sup_absorb mult_left_top one_sup_distributive sup.idem sup_top_right vector_zero_inf_comp)
  thus "sup_distributive x"
    by (simp add: sup_distributive_def)
qed

lemma co_test_sup_dist_contact:
  "co_test x  sup_dist_contact x"
  by (simp add: sup_dist_contact_def co_test_sup_distributive co_test_contact)

end

end

Theory Boolean_Semirings

(* Title:      Boolean Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Boolean Semirings›

theory Boolean_Semirings

imports Stone_Algebras.P_Algebras Lattice_Ordered_Semirings

begin

class complemented_distributive_lattice = bounded_distrib_lattice + uminus +
  assumes inf_complement: "x  (-x) = bot"
  assumes sup_complement: "x  (-x) = top"
begin

sublocale boolean_algebra where minus = "λx y . x  (-y)" and inf = inf and sup = sup and bot = bot and top = top
  apply unfold_locales
  apply (simp add: inf_complement)
  apply (simp add: sup_complement)
  by simp

end

text ‹M0-algebra›

context lattice_ordered_pre_left_semiring
begin

text ‹Section 7›

lemma vector_1:
  "vector x  x * top  x"
  by (simp add: antisym_conv top_right_mult_increasing)

definition zero_vector :: "'a  bool" where "zero_vector x  x  x * bot"
definition one_vector :: "'a  bool" where "one_vector x  x * bot  x"

lemma zero_vector_left_zero:
  assumes "zero_vector x"
    shows "x * y = x * bot"
proof -
  have "x * y  x * bot"
    by (metis assms mult_isotone top.extremum vector_mult_closed zero_vector zero_vector_def)
  thus ?thesis
    by (simp add: order.antisym mult_right_isotone)
qed

lemma zero_vector_1:
  "zero_vector x  (y . x * y = x * bot)"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_2:
  "zero_vector x  (y . x * y  x * bot)"
  by (metis eq_refl order_trans top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_3:
  "zero_vector x  x * 1 = x * bot"
  by (metis mult_sub_right_one zero_vector_def zero_vector_left_zero)

lemma zero_vector_4:
  "zero_vector x  x * 1  x * bot"
  using order.antisym mult_right_isotone zero_vector_3 by auto

lemma zero_vector_5:
  "zero_vector x  x * top = x * bot"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_6:
  "zero_vector x  x * top  x * bot"
  by (meson mult_right_isotone order_trans top.extremum zero_vector_2)

lemma zero_vector_7:
  "zero_vector x  (y . x * top = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_8:
  "zero_vector x  (y . x * top  x * y)"
  by (metis zero_vector_6 zero_vector_left_zero)

lemma zero_vector_9:
  "zero_vector x  (y . x * 1 = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_0:
  "zero_vector x  (y z . x * y = x * z)"
  by (metis zero_vector_5 zero_vector_left_zero)

text ‹Theorem 6 / Figure 2: relations between properties›

lemma co_vector_zero_vector_one_vector:
  "co_vector x  zero_vector x  one_vector x"
  using co_vector_def one_vector_def zero_vector_def by auto

lemma up_closed_one_vector:
  "up_closed x  one_vector x"
  by (metis bot_least mult_right_isotone up_closed_def one_vector_def)

lemma zero_vector_dense:
  "zero_vector x  dense_rel x"
  by (metis zero_vector_0 zero_vector_def)

lemma zero_vector_sup_distributive:
  "zero_vector x  sup_distributive x"
  by (metis sup_distributive_def sup_idem zero_vector_0)

lemma zero_vector_inf_distributive:
  "zero_vector x  inf_distributive x"
  by (metis inf_idem inf_distributive_def zero_vector_0)

lemma up_closed_zero_vector_vector:
  "up_closed x  zero_vector x  vector x"
  by (metis up_closed_def zero_vector_0)

lemma zero_vector_one_vector_vector:
  "zero_vector x  one_vector x  vector x"
  by (metis one_vector_def vector_1 zero_vector_0)

lemma co_vector_vector:
  "co_vector x  vector x"
  by (simp add: co_vector_zero_vector_one_vector zero_vector_one_vector_vector)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma zero_zero_vector:
  "zero_vector bot"
  by (simp add: zero_vector_def)

lemma sup_zero_vector:
  "zero_vector x  zero_vector y  zero_vector (x  y)"
  by (simp add: mult_right_dist_sup zero_vector_3)

lemma comp_zero_vector:
  "zero_vector x  zero_vector y  zero_vector (x * y)"
  by (metis mult_one_associative zero_vector_0)

text ‹one-vector›

lemma zero_one_vector:
  "one_vector bot"
  by (simp add: one_vector_def)

lemma one_one_vector:
  "one_vector 1"
  by (simp add: one_up_closed up_closed_one_vector)

lemma top_one_vector:
  "one_vector top"
  by (simp add: one_vector_def)

lemma sup_one_vector:
  "one_vector x  one_vector y  one_vector (x  y)"
  by (simp add: mult_right_dist_sup order_trans one_vector_def)

lemma inf_one_vector:
  "one_vector x  one_vector y  one_vector (x  y)"
  by (meson order.trans inf.boundedI mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right one_vector_def)

lemma comp_one_vector:
  "one_vector x  one_vector y  one_vector (x * y)"
  using mult_isotone mult_semi_associative order_lesseq_imp one_vector_def by blast

end

context multirelation_algebra_1
begin

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma top_zero_vector:
   "zero_vector top"
  by (simp add: mult_left_top zero_vector_def)

end

text ‹M1-algebra›

context multirelation_algebra_2
begin

text ‹Section 7›

lemma zero_vector_10:
  "zero_vector x  x * top = x * 1"
  by (metis mult_one_associative mult_top_associative zero_vector_7)

lemma zero_vector_11:
  "zero_vector x  x * top  x * 1"
  using order.antisym mult_right_isotone zero_vector_10 by fastforce

text ‹Theorem 6 / Figure 2: relations between properties›

lemma vector_zero_vector:
  "vector x  zero_vector x"
  by (simp add: zero_vector_def vector_left_annihilator)

lemma vector_up_closed_zero_vector:
  "vector x  up_closed x  zero_vector x"
  using up_closed_zero_vector_vector vector_up_closed vector_zero_vector by blast

lemma vector_zero_vector_one_vector:
  "vector x  zero_vector x  one_vector x"
  by (simp add: co_vector_zero_vector_one_vector vector_co_vector)

(*
lemma "(x * bot ⊓ y) * 1 = x * bot ⊓ y * 1" nitpick [expect=genuine,card=7] oops
*)

end

text ‹M3-algebra›

context up_closed_multirelation_algebra
begin

lemma up_closed:
  "up_closed x"
  by (simp add: up_closed_def)

lemma dedekind_1_left:
  "x * 1  y  (x  y * 1) * 1"
  by simp

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma zero_vector_dual:
  "zero_vector x  zero_vector (xd)"
  using up_closed_zero_vector_vector vector_dual vector_zero_vector up_closed by blast

end

text ‹complemented M0-algebra›

class lattice_ordered_pre_left_semiring_b = lattice_ordered_pre_left_semiring + complemented_distributive_lattice
begin

definition down_closed :: "'a  bool" where "down_closed x  -x * 1  -x"

text ‹Theorem 10 / Figure 3: closure properties›

text ‹down-closed›

lemma zero_down_closed:
  "down_closed bot"
  by (simp add: down_closed_def)

lemma top_down_closed:
  "down_closed top"
  by (simp add: down_closed_def)

lemma complement_down_closed_up_closed:
  "down_closed x  up_closed (-x)"
  using down_closed_def order.antisym mult_sub_right_one up_closed_def by auto

lemma sup_down_closed:
  "down_closed x  down_closed y  down_closed (x  y)"
  by (simp add: complement_down_closed_up_closed inf_up_closed)

lemma inf_down_closed:
  "down_closed x  down_closed y  down_closed (x  y)"
  by (simp add: complement_down_closed_up_closed sup_up_closed)

end

class multirelation_algebra_1b = multirelation_algebra_1 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

text ‹Theorem 7.1›

lemma complement_mult_zero_sub:
  "-(x * bot)  -x * bot"
proof -
  have "top = -x * bot  x * bot"
    by (metis compl_sup_top mult_left_top mult_right_dist_sup)
  thus ?thesis
    by (simp add: heyting.implies_order sup.commute)
qed

text ‹Theorem 7.2›

lemma transitive_zero_vector_complement:
  "transitive x  zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_mono mult_right_isotone order_trans zero_vector_def bot_least)

lemma transitive_dense_complement:
  "transitive x  dense_rel (-x)"
  by (simp add: zero_vector_dense transitive_zero_vector_complement)

lemma transitive_sup_distributive_complement:
  "transitive x  sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive transitive_zero_vector_complement)

lemma transitive_inf_distributive_complement:
  "transitive x  inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive transitive_zero_vector_complement)

lemma up_closed_zero_vector_complement:
  "up_closed x  zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_le_swap2 one_vector_def order_trans up_closed_one_vector zero_vector_def)

lemma up_closed_dense_complement:
  "up_closed x  dense_rel (-x)"
  by (simp add: zero_vector_dense up_closed_zero_vector_complement)

lemma up_closed_sup_distributive_complement:
  "up_closed x  sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive up_closed_zero_vector_complement)

lemma up_closed_inf_distributive_complement:
  "up_closed x  inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive up_closed_zero_vector_complement)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹closure under complement›

lemma co_total_total:
  "co_total x  total (-x)"
  by (metis complement_mult_zero_sub co_total_def compl_bot_eq mult_left_sub_dist_sup_right sup_bot_right top_le)

lemma complement_one_vector_zero_vector:
  "one_vector x  zero_vector (-x)"
  using compl_mono complement_mult_zero_sub one_vector_def order_trans zero_vector_def by blast

text ‹Theorem 6 / Figure 2: relations between properties›

lemma down_closed_zero_vector:
  "down_closed x  zero_vector x"
  using complement_down_closed_up_closed up_closed_zero_vector_complement by force

lemma down_closed_one_vector_vector:
  "down_closed x  one_vector x  vector x"
  by (simp add: down_closed_zero_vector zero_vector_one_vector_vector)

(*
lemma complement_vector: "vector x ⟶ vector (-x)" nitpick [expect=genuine,card=8] oops
*)

end

class multirelation_algebra_1c = multirelation_algebra_1b +
  assumes dedekind_top_left: "x * top  y  (x  y * top) * top"
  assumes comp_zero_inf: "(x * bot  y) * bot  (x  y) * bot"
begin

text ‹Theorem 7.3›

lemma schroeder_top_sub:
  "-(x * top) * top  -x"
proof -
  have "-(x * top) * top  x  bot"
    by (metis dedekind_top_left p_inf zero_vector)
  thus ?thesis
    by (simp add: shunting_1)
qed

text ‹Theorem 7.4›

lemma schroeder_top:
  "x * top  y  -y * top  -x"
  apply (rule iffI)
  using compl_mono inf.order_trans mult_left_isotone schroeder_top_sub apply blast
  by (metis compl_mono double_compl mult_left_isotone order_trans schroeder_top_sub)

text ‹Theorem 7.5›

lemma schroeder_top_eq:
  "-(x * top) * top = -(x * top)"
  using vector_1 vector_mult_closed vector_top_closed schroeder_top by auto

lemma schroeder_one_eq:
  "-(x * top) * 1 = -(x * top)"
  by (metis top_mult_right_one schroeder_top_eq)

text ‹Theorem 7.6›

lemma vector_inf_comp:
  "x * top  y * z = (x * top  y) * z"
proof (rule order.antisym)
  have "x * top  y * z = x * top  ((x * top  y)  (-(x * top)  y)) * z"
    by (simp add: inf_commute)
  also have "... = x * top  ((x * top  y) * z  (-(x * top)  y) * z)"
    by (simp add: inf_sup_distrib2 mult_right_dist_sup)
  also have "... = (x * top  (x * top  y) * z)  (x * top  (-(x * top)  y) * z)"
    by (simp add: inf_sup_distrib1)
  also have "...  (x * top  y) * z  (x * top  (-(x * top)  y) * z)"
    by (simp add: le_infI2)
  also have "...  (x * top  y) * z  (x * top  -(x * top) * z)"
    by (metis inf.sup_left_isotone inf_commute mult_right_sub_dist_inf_left sup_right_isotone)
  also have "...  (x * top  y) * z  (x * top  -(x * top) * top)"
    using inf.sup_right_isotone mult_right_isotone sup_right_isotone by auto
  also have "... = (x * top  y) * z"
    by (simp add: schroeder_top_eq)
  finally show "x * top  y * z  (x * top  y) * z"
    .
next
  show "(x * top  y) * z  x * top  y * z"
    by (metis inf.bounded_iff mult_left_top mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right mult_semi_associative order_lesseq_imp)
qed

(*
lemma dedekind_top_left:
  "x * top ⊓ y ≤ (x ⊓ y * top) * top"
  by (metis inf.commute top_right_mult_increasing vector_inf_comp)
*)

text ‹Theorem 7.7›

lemma vector_zero_inf_comp:
  "(x * bot  y) * z = x * bot  y * z"
  by (metis vector_inf_comp vector_mult_closed zero_vector)

lemma vector_zero_inf_comp_2:
  "(x * bot  y) * z = (x * bot  y * 1) * z"
  by (simp add: vector_zero_inf_comp)

text ‹Theorem 7.8›

lemma comp_zero_inf_2:
  "x * bot  y * bot = (x  y) * bot"
  using order.antisym mult_right_sub_dist_inf comp_zero_inf vector_zero_inf_comp by auto

lemma comp_zero_inf_3:
  "x * bot  y * bot = (x * bot  y) * bot"
  by (simp add: vector_zero_inf_comp)

lemma comp_zero_inf_4:
  "x * bot  y * bot = (x * bot  y * bot) * bot"
  by (metis comp_zero_inf_2 inf.commute vector_zero_inf_comp)

lemma comp_zero_inf_5:
  "x * bot  y * bot = (x * 1  y * 1) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

lemma comp_zero_inf_6:
  "x * bot  y * bot = (x * 1  y * bot) * bot"
  using inf.sup_monoid.add_commute vector_zero_inf_comp by fastforce

lemma comp_zero_inf_7:
  "x * bot  y * bot = (x * 1  y) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

text ‹Theorem 10 / Figure 3: closure properties›

text ‹zero-vector›

lemma inf_zero_vector:
  "zero_vector x  zero_vector y  zero_vector (x  y)"
  by (metis comp_zero_inf_2 inf.sup_mono zero_vector_def)

text ‹down-closed›

lemma comp_down_closed:
  "down_closed x  down_closed y  down_closed (x * y)"
  by (metis complement_down_closed_up_closed down_closed_zero_vector up_closed_def zero_vector_0 schroeder_one_eq)

text ‹closure under complement›

lemma complement_vector:
  "vector x  vector (-x)"
  using vector_1 schroeder_top by blast

lemma complement_zero_vector_one_vector:
  "zero_vector x  one_vector (-x)"
  by (metis comp_zero_inf_2 order.antisym complement_mult_zero_sub double_compl inf.sup_monoid.add_commute mult_left_zero one_vector_def order.refl pseudo_complement top_right_mult_increasing zero_vector_0)

lemma complement_zero_vector_one_vector_iff:
  "zero_vector x  one_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

lemma complement_one_vector_zero_vector_iff:
  "one_vector x  zero_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

text ‹Theorem 6 / Figure 2: relations between properties›

lemma vector_down_closed:
  "vector x  down_closed x"
  using complement_vector complement_down_closed_up_closed vector_up_closed by blast

lemma co_vector_down_closed:
  "co_vector x  down_closed x"
  by (simp add: co_vector_vector vector_down_closed)

lemma vector_down_closed_one_vector:
  "vector x  down_closed x  one_vector x"
  using down_closed_one_vector_vector up_closed_one_vector vector_up_closed vector_down_closed by blast

lemma vector_up_closed_down_closed:
  "vector x  up_closed x  down_closed x"
  using down_closed_zero_vector up_closed_zero_vector_vector vector_up_closed vector_down_closed by blast

text ‹Section 7›

lemma vector_b1:
  "vector x  -x * top = -x"
  using complement_vector by auto

lemma vector_b2:
  "vector x  -x * bot = -x"
  by (metis down_closed_zero_vector vector_mult_closed zero_vector zero_vector_left_zero vector_b1 vector_down_closed)

lemma covector_b1:
  "co_vector x  -x * top = -x"
  using co_vector_def co_vector_vector vector_b1 vector_b2 by force

lemma covector_b2:
  "co_vector x  -x * bot = -x"
  using covector_b1 vector_b1 vector_b2 by auto

lemma vector_co_vector_iff:
  "vector x  co_vector x"
  by (simp add: covector_b2 vector_b2)

lemma zero_vector_b:
  "zero_vector x  -x * bot  -x"
  by (simp add: complement_zero_vector_one_vector_iff one_vector_def)

lemma one_vector_b1:
  "one_vector x  -x  -x * bot"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_def)

lemma one_vector_b0:
  "one_vector x  (y z . -x * y = -x * z)"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_0)

(*
lemma schroeder_one: "x * -1 ≤ y ⟷ -y * -1 ≤ -x" nitpick [expect=genuine,card=8] oops
*)

end

class multirelation_algebra_2b = multirelation_algebra_2 + complemented_distributive_lattice
begin

subclass multirelation_algebra_1b ..

(*
lemma "-x * bot ≤ -(x * bot)" nitpick [expect=genuine,card=8] oops
*)

end

text ‹complemented M1-algebra›

class multirelation_algebra_2c = multirelation_algebra_2b + multirelation_algebra_1c

class multirelation_algebra_3b = multirelation_algebra_3 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

lemma dual_complement_commute:
  "-(xd) = (-x)d"
  by (metis compl_unique dual_dist_sup dual_dist_inf dual_top dual_zero inf_complement sup_compl_top)

end

text ‹complemented M2-algebra›

class multirelation_algebra_5b = multirelation_algebra_5 + complemented_distributive_lattice
begin

subclass multirelation_algebra_2b ..

subclass multirelation_algebra_3b ..

lemma dual_down_closed:
  "down_closed x  down_closed (xd)"
  using complement_down_closed_up_closed dual_complement_commute dual_up_closed by auto

end

class multirelation_algebra_5c = multirelation_algebra_5b + multirelation_algebra_1c
begin

lemma complement_mult_zero_below:
  "-x * bot  -(x * bot)"
  by (simp add: comp_zero_inf_2 shunting_1)

(*
lemma "x * 1 ⊓ y * 1 ≤ (x ⊓ y) * 1" nitpick [expect=genuine,card=4] oops
lemma "x * 1 ⊓ (y * 1) ≤ (x * 1 ⊓ y) * 1" nitpick [expect=genuine,card=4] oops
*)

end

class up_closed_multirelation_algebra_b = up_closed_multirelation_algebra + complemented_distributive_lattice
begin

subclass multirelation_algebra_5c
  apply unfold_locales
  apply (metis inf.sup_monoid.add_commute top_right_mult_increasing vector_inf_comp)
  using mult_right_dist_inf vector_zero_inf_comp by auto

lemma complement_zero_vector:
  "zero_vector x  zero_vector (-x)"
  by (simp add: zero_right_mult_decreasing zero_vector_b)

lemma down_closed:
  "down_closed x"
  by (simp add: down_closed_def)

lemma vector:
  "vector x"
  by (simp add: down_closed up_closed_def vector_up_closed_down_closed)

end

end

Theory Binary_Iterings

(* Title:      Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Binary Iterings›

theory Binary_Iterings

imports Base

begin

class binary_itering = idempotent_left_zero_semiring + while +
  assumes while_productstar: "(x * y)  z = z  x * ((y * x)  (y * z))"
  assumes while_sumstar: "(x  y)  z = (x  y)  (x  z)"
  assumes while_left_dist_sup: "x  (y  z) = (x  y)  (x  z)"
  assumes while_sub_associative: "(x  y) * z  x  (y * z)"
  assumes while_simulate_left_plus: "x * z  z * (y  1)  w  x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
  assumes while_simulate_right_plus: "z * x  y * (y  z)  w  z * (x  v)  y  (z * v  w * (x  v))"
begin

text ‹Theorem 9.1›

lemma while_zero:
  "bot  x = x"
  by (metis sup_bot_right mult_left_zero while_productstar)

text ‹Theorem 9.4›

lemma while_mult_increasing:
  "x * y  x  y"
  by (metis le_supI2 mult.left_neutral mult_left_sub_dist_sup_left while_productstar)

text ‹Theorem 9.2›

lemma while_one_increasing:
  "x  x  1"
  by (metis mult.right_neutral while_mult_increasing)

text ‹Theorem 9.3›

lemma while_increasing:
  "y  x  y"
  by (metis sup_left_divisibility mult_left_one while_productstar)

text ‹Theorem 9.42›

lemma while_right_isotone:
  "y  z  x  y  x  z"
  by (metis le_iff_sup while_left_dist_sup)

text ‹Theorem 9.41›

lemma while_left_isotone:
  "x  y  x  z  y  z"
  using sup_left_divisibility while_sumstar while_increasing by auto

lemma while_isotone:
  "w  x  y  z  w  y  x  z"
  by (meson order_lesseq_imp while_left_isotone while_right_isotone)

text ‹Theorem 9.17›

lemma while_left_unfold:
  "x  y = y  x * (x  y)"
  by (metis mult_1_left mult_1_right while_productstar)

lemma while_simulate_left_plus_1:
  "x * z  z * (y  1)  x  (z * w)  z * (y  w)  (x  bot)"
  by (metis sup_bot_right mult_left_zero while_simulate_left_plus)

text ‹Theorem 11.1›

lemma while_simulate_absorb:
  "y * x  x  y  x  x  (y  bot)"
  by (metis while_simulate_left_plus_1 while_zero mult_1_right)

text ‹Theorem 9.10›

lemma while_transitive:
  "x  (x  y) = x  y"
  by (metis order.eq_iff sup_bot_right sup_ge2 while_left_dist_sup while_increasing while_left_unfold while_simulate_absorb)

text ‹Theorem 9.25›

lemma while_slide:
  "(x * y)  (x * z) = x * ((y * x)  z)"
  by (metis mult_left_dist_sup while_productstar mult_assoc while_left_unfold)

text ‹Theorem 9.21›

lemma while_zero_2:
  "(x * bot)  y = x * bot  y"
  by (metis mult_left_zero sup_commute mult_assoc while_left_unfold)

text ‹Theorem 9.5›

lemma while_mult_star_exchange:
  "x * (x  y) = x  (x * y)"
  by (metis mult_left_one while_slide)

text ‹Theorem 9.18›

lemma while_right_unfold:
  "x  y = y  (x  (x * y))"
  by (metis while_left_unfold while_mult_star_exchange)

text ‹Theorem 9.7›

lemma while_one_mult_below:
  "(x  1) * y  x  y"
  by (metis mult_left_one while_sub_associative)

lemma while_plus_one:
  "x  y = y  (x  y)"
  by (simp add: sup.absorb2 while_increasing)

text ‹Theorem 9.19›

lemma while_rtc_2:
  "y  x * y  (x  (x  y)) = x  y"
  by (simp add: sup_absorb2 while_increasing while_mult_increasing while_transitive)

text ‹Theorem 9.6›

lemma while_left_plus_below:
  "x * (x  y)  x  y"
  by (metis sup_right_divisibility while_left_unfold)

lemma while_right_plus_below:
  "x  (x * y)  x  y"
  using while_left_plus_below while_mult_star_exchange by auto

lemma while_right_plus_below_2:
  "(x  x) * y  x  y"
  by (smt order_trans while_right_plus_below while_sub_associative)

text ‹Theorem 9.47›

lemma while_mult_transitive:
  "x  z  y  y  z  w  x  z  w"
  by (smt order_trans while_right_isotone while_transitive)

text ‹Theorem 9.48›

lemma while_mult_upper_bound:
  "x  z  1  y  z  w  x * y  z  w"
  by (metis order.trans mult_isotone while_one_mult_below while_transitive)

lemma while_one_mult_while_below:
  "(y  1) * (y  v)  y  v"
  by (simp add: while_mult_upper_bound)

text ‹Theorem 9.34›

lemma while_sub_dist:
  "x  z  (x  y)  z"
  by (simp add: while_left_isotone)

lemma while_sub_dist_1:
  "x * z  (x  y)  z"
  using order.trans while_mult_increasing while_sub_dist by blast

lemma while_sub_dist_2:
  "x * y * z  (x  y)  z"
  by (metis sup_commute mult_assoc while_mult_transitive while_sub_dist_1)

text ‹Theorem 9.36›

lemma while_sub_dist_3:
  "x  (y  z)  (x  y)  z"
  by (metis sup_commute while_mult_transitive while_sub_dist)

text ‹Theorem 9.44›

lemma while_absorb_2:
  "x  y  y  (x  z) = y  z"
  using sup_left_divisibility while_sumstar while_transitive by auto

lemma while_simulate_right_plus_1:
  "z * x  y * (y  z)  z * (x  w)  y  (z * w)"
  by (metis sup_bot_right mult_left_zero while_simulate_right_plus)

text ‹Theorem 9.39›

lemma while_sumstar_1_below:
  "x  ((y * (x  1))  z)  ((x  1) * y)  (x  z)"
proof -
  have 1: "x * (((x  1) * y)  (x  z))  ((x  1) * y)  (x  z)"
    by (smt sup_mono sup_ge2 mult_assoc mult_left_dist_sup mult_right_sub_dist_sup_right while_left_unfold)
  have "x  ((y * (x  1))  z)  (x  z)  (x  (y * (((x  1) * y)  ((x  1) * z))))"
    by (metis eq_refl while_left_dist_sup while_productstar)
  also have "...  (x  z)  (x  ((x  1) * y * (((x  1) * y)  ((x  1) * z))))"
    by (metis sup_right_isotone mult_assoc mult_left_one mult_right_sub_dist_sup_left while_left_unfold while_right_isotone)
  also have "...  (x  z)  (x  (((x  1) * y)  ((x  1) * z)))"
    using semiring.add_left_mono while_left_plus_below while_right_isotone by blast
  also have "...  x  (((x  1) * y)  (x  z))"
    by (meson order.trans le_supI while_increasing while_one_mult_below while_right_isotone)
  also have "...  (((x  1) * y)  (x  z))  (x  bot)"
    using 1 while_simulate_absorb by auto
  also have "... = ((x  1) * y)  (x  z)"
    by (smt sup_assoc sup_commute sup_bot_left while_left_dist_sup while_left_unfold)
  finally show ?thesis
    .
qed

lemma while_sumstar_2_below:
  "((x  1) * y)  (x  z)  (x  y)  (x  z)"
  by (simp add: while_left_isotone while_one_mult_below)

text ‹Theorem 9.38›

lemma while_sup_1_below:
  "x  ((y * (x  1))  z)  (x  y)  z"
proof -
  have "((x  1) * y)  ((x  1) * z)  (x  y)  z"
    using while_sumstar while_isotone while_one_mult_below by auto
  hence "(y * (x  1))  z  z  y * ((x  y)  z)"
    by (metis sup_right_isotone mult_right_isotone while_productstar)
  also have "...  (x  y)  z"
    by (metis sup_right_isotone sup_ge2 mult_left_isotone while_left_unfold)
  finally show ?thesis
    using while_mult_transitive while_sub_dist by blast
qed

text ‹Theorem 9.16›

lemma while_while_while:
  "((x  1)  1)  y = (x  1)  y"
  by (smt (z3) sup.absorb1 while_sumstar while_absorb_2 while_increasing while_one_increasing)

lemma while_one:
  "(1  1)  y = 1  y"
  by (metis while_while_while while_zero)

text ‹Theorem 9.22›

lemma while_sup_below:
  "x  y  x  (y  1)"
  by (metis le_supI le_supI1 while_left_dist_sup while_left_unfold while_one_increasing)

text ‹Theorem 9.32›

lemma while_sup_2:
  "(x  y)  z  (x  (y  1))  z"
  using while_left_isotone while_sup_below by auto

text ‹Theorem 9.45›

lemma while_sup_one_left_unfold:
  "1  x  x * (x  y) = x  y"
  by (metis order.antisym mult_1_left mult_left_isotone while_left_plus_below)

lemma while_sup_one_right_unfold:
  "1  x  x  (x * y) = x  y"
  using while_mult_star_exchange while_sup_one_left_unfold by auto

text ‹Theorem 9.30›

lemma while_decompose_7:
  "(x  y)  z = x  (y  ((x  y)  z))"
  by (metis order.eq_iff order_trans while_increasing while_sub_dist_3 while_transitive)

text ‹Theorem 9.31›

lemma while_decompose_8:
  "(x  y)  z = (x  y)  (x  (y  z))"
  using while_absorb_2 by auto

text ‹Theorem 9.27›

lemma while_decompose_9:
  "(x  (y  1))  z = x  (y  ((x  (y  1))  z))"
  by (smt sup_commute le_iff_sup order_trans while_sup_below while_increasing while_sub_dist_3)

lemma while_decompose_10:
  "(x  (y  1))  z = (x  (y  1))  (x  (y  z))"
proof -
  have 1: "(x  (y  1))  z  (x  (y  1))  (x  (y  z))"
    by (meson order.trans while_increasing while_right_isotone)
  have "x  (y  1)  x  (y  1)"
    using while_increasing while_sup_below by auto
  hence "(x  (y  1))  (x  (y  z))  (x  (y  1))  z"
    using while_absorb_2 while_sup_below by force
  thus ?thesis
    using 1 order.antisym by blast
qed

lemma while_back_loop_fixpoint:
  "z * (y  (y * x))  z * x = z * (y  x)"
  by (metis sup_commute mult_left_dist_sup while_right_unfold)

lemma while_back_loop_prefixpoint:
  "z * (y  1) * y  z  z * (y  1)"
  by (metis le_supI le_supI2 mult_1_right mult_right_isotone mult_assoc while_increasing while_one_mult_below while_right_unfold)

text ‹Theorem 9›

lemma while_loop_is_fixpoint:
  "is_fixpoint (λx . y * x  z) (y  z)"
  using is_fixpoint_def sup_commute while_left_unfold by auto

text ‹Theorem 9›

lemma while_back_loop_is_prefixpoint:
  "is_prefixpoint (λx . x * y  z) (z * (y  1))"
  using is_prefixpoint_def while_back_loop_prefixpoint by auto

text ‹Theorem 9.20›

lemma while_while_sup:
  "(1  x)  y = (x  1)  y"
  by (metis sup_commute while_decompose_10 while_sumstar while_zero)

lemma while_while_mult_sub:
  "x  (1  y)  (x  1)  y"
  by (metis sup_commute while_sub_dist_3 while_while_sup)

text ‹Theorem 9.11›

lemma while_right_plus:
  "(x  x)  y = x  y"
  by (metis sup_idem while_plus_one while_sumstar while_transitive)

text ‹Theorem 9.12›

lemma while_left_plus:
  "(x * (x  1))  y = x  y"
  by (simp add: while_mult_star_exchange while_right_plus)

text ‹Theorem 9.9›

lemma while_below_while_one:
  "x  x  x  1"
  by (meson eq_refl while_mult_transitive while_one_increasing)

lemma while_below_while_one_mult:
  "x * (x  x)  x * (x  1)"
  by (simp add: mult_right_isotone while_below_while_one)

text ‹Theorem 9.23›

lemma while_sup_sub_sup_one:
  "x  (x  y)  x  (1  y)"
  using semiring.add_right_mono while_left_dist_sup while_below_while_one by auto

lemma while_sup_sub_sup_one_mult:
  "x * (x  (x  y))  x * (x  (1  y))"
  by (simp add: mult_right_isotone while_sup_sub_sup_one)

lemma while_elimination:
  "x * y = bot  x * (y  z) = x * z"
  by (metis sup_bot_right mult_assoc mult_left_dist_sup mult_left_zero while_left_unfold)

text ‹Theorem 9.8›

lemma while_square:
  "(x * x)  y  x  y"
  by (metis while_left_isotone while_mult_increasing while_right_plus)

text ‹Theorem 9.35›

lemma while_mult_sub_sup:
  "(x * y)  z  (x  y)  z"
  by (metis while_increasing while_isotone while_mult_increasing while_sumstar)

text ‹Theorem 9.43›

lemma while_absorb_1:
  "x  y  x  (y  z) = y  z"
  by (metis order.antisym le_iff_sup while_increasing while_sub_dist_3)

lemma while_absorb_3:
  "x  y  x  (y  z) = y  (x  z)"
  by (simp add: while_absorb_1 while_absorb_2)

text ‹Theorem 9.24›

lemma while_square_2:
  "(x * x)  ((x  1) * y)  x  y"
  by (metis le_supI while_increasing while_mult_transitive while_mult_upper_bound while_one_increasing while_square)

lemma while_separate_unfold_below:
  "(y * (x  1))  z  (y  z)  (y  (y * x * (x  ((y * (x  1))  z))))"
proof -
  have "(y * (x  1))  z = (y  (y * x * (x  1)))  (y  z)"
    by (metis mult_assoc mult_left_dist_sup mult_1_right while_left_unfold while_sumstar)
  hence "(y * (x  1))  z = (y  z)  (y  (y * x * (x  1))) * ((y * (x  1))  z)"
    using while_left_unfold by auto
  also have "...  (y  z)  (y  (y * x * (x  1)) * ((y * (x  1))  z))"
    using sup_right_isotone while_sub_associative by auto
  also have "...  (y  z)  (y  (y * x * (x  ((y * (x  1))  z))))"
    by (smt sup_right_isotone mult_assoc mult_right_isotone while_one_mult_below while_right_isotone)
  finally show ?thesis
    .
qed

text ‹Theorem 9.33›

lemma while_mult_zero_sup:
  "(x  y * bot)  z = x  ((y * bot)  z)"
proof -
  have "(x  y * bot)  z = (x  (y * bot))  (x  z)"
    by (simp add: while_sumstar)
  also have "... = (x  z)  (x  (y * bot)) * ((x  (y * bot))  (x  z))"
    using while_left_unfold by auto
  also have "...  (x  z)  (x  (y * bot))"
    by (metis sup_right_isotone mult_assoc mult_left_zero while_sub_associative)
  also have "... = x  ((y * bot)  z)"
    by (simp add: sup_commute while_left_dist_sup while_zero_2)
  finally show ?thesis
    by (simp add: order.antisym while_sub_dist_3)
qed

lemma while_sup_mult_zero:
  "(x  y * bot)  y = x  y"
  by (simp add: sup_absorb2 zero_right_mult_decreasing while_mult_zero_sup while_zero_2)

lemma while_mult_zero_sup_2:
  "(x  y * bot)  z = (x  z)  (x  (y * bot))"
  by (simp add: sup_commute while_left_dist_sup while_mult_zero_sup while_zero_2)

lemma while_sup_zero_star:
  "(x  y * bot)  z = x  (y * bot  z)"
  by (simp add: while_mult_zero_sup while_zero_2)

lemma while_unfold_sum:
  "(x  y)  z = (x  z)  (x  (y * ((x  y)  z)))"
  apply (rule order.antisym)
  apply (metis semiring.add_left_mono while_sub_associative while_sumstar while_left_unfold)
  by (metis le_supI while_decompose_7 while_mult_increasing while_right_isotone while_sub_dist)

lemma while_simulate_left:
  "x * z  z * y  w  x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
  by (metis sup_left_isotone mult_right_isotone order_trans while_one_increasing while_simulate_left_plus)

lemma while_simulate_right:
  assumes "z * x  y * z  w"
    shows "z * (x  v)  y  (z * v  w * (x  v))"
proof -
  have "y * z  w  y * (y  z)  w"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  thus ?thesis
    by (meson assms order.trans while_simulate_right_plus)
qed

lemma while_simulate:
  "z * x  y * z  z * (x  v)  y  (z * v)"
  by (metis sup_bot_right mult_left_zero while_simulate_right)

text ‹Theorem 9.14›

lemma while_while_mult:
  "1  (x  y) = (x  1)  y"
proof -
  have "(x  1)  y  (x  1) * ((x  1)  y)"
    by (simp add: while_increasing while_sup_one_left_unfold)
  also have "...  1  ((x  1) * y)"
    by (simp add: while_one_mult_while_below while_simulate)
  also have "...  1  (x  y)"
    by (simp add: while_isotone while_one_mult_below)
  finally show ?thesis
    by (metis order.antisym while_sub_dist_3 while_while_sup)
qed

lemma while_simulate_left_1:
  "x * z  z * y  x  (z * v)  z * (y  v)  (x  bot)"
  by (meson order.trans mult_right_isotone while_one_increasing while_simulate_left_plus_1)

text ‹Theorem 9.46›

lemma while_associative_1:
  assumes "1  z"
  shows "x  (y * z) = (x  y) * z"
proof -
  have "x  (y * z)  x  ((x  y) * z)"
    by (simp add: mult_isotone while_increasing while_right_isotone)
  also have "...  (x  y) * (bot  z)  (x  bot)"
    by (metis mult_assoc mult_right_sub_dist_sup_right while_left_unfold while_simulate_absorb while_zero)
  also have "...  (x  y) * z  (x  bot) * z"
    by (metis assms le_supI sup_ge1 sup_ge2 case_split_right while_plus_one while_zero)
  also have "... = (x  y) * z"
    by (metis sup_bot_right mult_right_dist_sup while_left_dist_sup)
  finally show ?thesis
    by (simp add: order.antisym while_sub_associative)
qed

text ‹Theorem 9.29›

lemma while_associative_while_1:
  "x  (y * (z  1)) = (x  y) * (z  1)"
  by (simp add: while_associative_1 while_increasing)

text ‹Theorem 9.13›

lemma while_one_while:
  "(x  1) * (y  1) = x  (y  1)"
  by (metis mult_left_one while_associative_while_1)

lemma while_decompose_5_below:
  "(x  (y  1))  z  (y  (x  1))  z"
  by (smt (z3) while_left_dist_sup while_sumstar while_absorb_2 while_one_increasing while_plus_one while_sub_dist)

text ‹Theorem 9.26›

lemma while_decompose_5:
  "(x  (y  1))  z = (y  (x  1))  z"
  by (simp add: order.antisym while_decompose_5_below)

lemma while_decompose_4:
  "(x  (y  1))  z = x  ((y  (x  1))  z)"
  using while_absorb_1 while_decompose_5 while_sup_below by auto

text ‹Theorem 11.7›

lemma while_simulate_2:
  "y * (x  1)  x  (y  1)  y  (x  1)  x  (y  1)"
proof
  assume "y * (x  1)  x  (y  1)"
  hence "y * (x  1)  (x  1) * (y  1)"
    by (simp add: while_one_while)
  hence "y  ((x  1) * 1)  (x  1) * (y  1)  (y  bot)"
    using while_simulate_left_plus_1 by blast
  hence "y  (x  1)  (x  (y  1))  (y  bot)"
    by (simp add: while_one_while)
  also have "... = x  (y  1)"
    by (metis sup_commute le_iff_sup order_trans while_increasing while_right_isotone bot_least)
  finally show "y  (x  1)  x  (y  1)"
    .
next
  assume "y  (x  1)  x  (y  1)"
  thus "y * (x  1)  x  (y  1)"
    using order_trans while_mult_increasing by blast
qed

lemma while_simulate_1:
  "y * x  x * y  y  (x  1)  x  (y  1)"
  by (metis order_trans while_mult_increasing while_right_isotone while_simulate while_simulate_2)

lemma while_simulate_3:
  "y * (x  1)  x  1  y  (x  1)  x  (y  1)"
  by (meson order.trans while_increasing while_right_isotone while_simulate_2)

text ‹Theorem 9.28›

lemma while_extra_while:
  "(y * (x  1))  z = (y * (y  (x  1)))  z"
proof -
  have "y * (y  (x  1))  y * (x  1) * (y * (x  1)  1)"
    using while_back_loop_prefixpoint while_left_isotone while_mult_star_exchange by auto
  hence 1: "(y * (y  (x  1)))  z  (y * (x  1))  z"
    by (metis while_simulate_right_plus_1 mult_left_one)
  have "(y * (x  1))  z  (y * (y  (x  1)))  z"
    by (simp add: while_increasing while_left_isotone while_mult_star_exchange)
  thus ?thesis
    using 1 order.antisym by auto
qed

text ‹Theorem 11.6›

lemma while_separate_4:
  assumes "y * x  x * (x  (1  y))"
    shows "(x  y)  z = x  (y  z)"
proof -
  have "(1  y) * x  x * (x  (1  y))"
    by (smt assms sup_assoc le_supI mult_left_one mult_left_sub_dist_sup_left mult_right_dist_sup mult_1_right while_left_unfold)
  hence 1: "(1  y) * (x  1)  x  (1  y)"
    by (metis mult_1_right while_simulate_right_plus_1)
  have "y * x * (x  1)  x * (x  ((1  y) * (x  1)))"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup while_associative_1 while_increasing)
  also have "...  x * (x  (1  y))"
    using 1 mult_right_isotone while_mult_transitive by blast
  also have "...  x * (x  1) * (y  1)"
    by (simp add: mult_right_isotone mult_assoc while_increasing while_one_increasing while_one_while while_right_isotone)
  finally have "y  (x * (x  1))  x * (x  1) * (y  1)  (y  bot)"
    by (metis mult_assoc mult_1_right while_simulate_left_plus_1)
  hence "(y  1) * (y  x)  x * (x  y  1)  (y  bot)"
    by (smt le_iff_sup mult_assoc mult_1_right order_refl order_trans while_absorb_2 while_left_dist_sup while_mult_star_exchange while_one_mult_below while_one_while while_plus_one)
  hence "(y  1) * ((y  x)  (y  z))  x  ((y  1) * (y  z)  (y  bot) * ((y  x)  (y  z)))"
    by (simp add: while_simulate_right_plus)
  also have "...  x  ((y  z)  (y  bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x  y  z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

lemma while_separate_5:
  "y * x  x * (x  (x  y))  (x  y)  z = x  (y  z)"
  using order_lesseq_imp while_separate_4 while_sup_sub_sup_one_mult by blast

lemma while_separate_6:
  "y * x  x * (x  y)  (x  y)  z = x  (y  z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_separate_5)

text ‹Theorem 11.4›

lemma while_separate_1:
  "y * x  x * y  (x  y)  z = x  (y  z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_separate_6 by blast

text ‹Theorem 11.2›

lemma while_separate_mult_1:
  "y * x  x * y  (x * y)  z  x  (y  z)"
  by (metis while_mult_sub_sup while_separate_1)

text ‹Theorem 11.5›

lemma separation:
  assumes "y * x  x * (y  1)"
    shows "(x  y)  z = x  (y  z)"
proof -
  have "y  x  x * (y  1)  (y  bot)"
    by (metis assms mult_1_right while_simulate_left_plus_1)
  also have "...  x * (x  y  1)  (y  bot)"
    using sup_left_isotone while_increasing while_mult_star_exchange by force
  finally have "(y  1) * (y  x)  x * (x  y  1)  (y  bot)"
    using order.trans while_one_mult_while_below by blast
  hence "(y  1) * ((y  x)  (y  z))  x  ((y  1) * (y  z)  (y  bot) * ((y  x)  (y  z)))"
    by (simp add: while_simulate_right_plus)
  also have "...  x  ((y  z)  (y  bot))"
    by (metis sup_mono mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x  y  z"
    using sup.absorb_iff1 while_right_isotone by auto
  finally show ?thesis
    by (smt sup_commute le_iff_sup mult_left_one mult_right_dist_sup while_plus_one while_sub_associative while_sumstar)
qed

text ‹Theorem 11.5›

lemma while_separate_left:
  "y * x  x * (y  1)  y  (x  z)  x  (y  z)"
  by (metis sup_commute separation while_sub_dist_3)

text ‹Theorem 11.6›

lemma while_simulate_4:
  "y * x  x * (x  (1  y))  y  (x  z)  x  (y  z)"
  by (metis sup_commute while_separate_4 while_sub_dist_3)

lemma while_simulate_5:
  "y * x  x * (x  (x  y))  y  (x  z)  x  (y  z)"
  by (smt order_trans while_sup_sub_sup_one_mult while_simulate_4)

lemma while_simulate_6:
  "y * x  x * (x  y)  y  (x  z)  x  (y  z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_simulate_5)

text ‹Theorem 11.3›

lemma while_simulate_7:
  "y * x  x * y  y  (x  z)  x  (y  z)"
  using mult_left_sub_dist_sup_right order_lesseq_imp while_simulate_6 by blast

lemma while_while_mult_1:
  "x  (1  y) = 1  (x  y)"
  by (metis sup_commute mult_left_one mult_1_right order_refl while_separate_1)

text ‹Theorem 9.15›

lemma while_while_mult_2:
  "x  (1  y) = (x  1)  y"
  by (simp add: while_while_mult while_while_mult_1)

text ‹Theorem 11.8›

lemma while_import:
  assumes "p  p * p  p  1  p * x  x * p"
    shows "p * (x  y) = p * ((p * x)  y)"
proof -
  have "p * (x  y)  (p * x)  (p * y)"
    using assms test_preserves_equation while_simulate by auto
  also have "...  (p * x)  y"
    by (metis assms le_iff_sup mult_left_one mult_right_dist_sup while_right_isotone)
  finally have 2: "p * (x  y)  p * ((p * x)  y)"
    by (smt assms sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_1_right)
  have "p * ((p * x)  y)  p * (x  y)"
    by (metis assms mult_left_isotone mult_left_one mult_right_isotone while_left_isotone)
  thus ?thesis
    using 2 order.antisym by auto
qed

text ‹Theorem 11.8›

lemma while_preserve:
  assumes "p  p * p"
      and "p  1"
      and "p * x  x * p"
    shows "p * (x  y) = p * (x  (p * y))"
proof (rule order.antisym)
  show "p * (x  y)  p * (x  (p * y))"
    by (metis assms order.antisym coreflexive_transitive mult_right_isotone mult_assoc while_simulate)
  show "p * (x  (p * y))  p * (x  y)"
    by (metis assms(2) mult_left_isotone mult_left_one mult_right_isotone while_right_isotone)
qed

lemma while_plus_below_while:
  "(x  1) * x  x  1"
  by (simp add: while_mult_upper_bound while_one_increasing)

text ‹Theorem 9.40›

lemma while_01:
  "(w * (x  1))  (y * z)  (x  w)  ((x  y) * z)"
proof -
  have "(w * (x  1))  (y * z) = y * z  w * (((x  1) * w)  ((x  1) * y * z))"
    by (metis mult_assoc while_productstar)
  also have "...  y * z  w * ((x  w)  ((x  y) * z))"
    by (metis sup_right_isotone mult_left_isotone mult_right_isotone while_isotone while_one_mult_below)
  also have "...  (x  y) * z  (x  w) * ((x  w)  ((x  y) * z))"
    by (meson mult_left_isotone semiring.add_mono while_increasing)
  finally show ?thesis
    using while_left_unfold by auto
qed

text ‹Theorem 9.37›

lemma while_while_sub_associative:
  "x  (y  z)  ((x  y)  z)  (x  z)"
proof -
  have 1: "x * (x  1)  (x  1) * ((x  y)  1)"
    by (metis le_supE while_back_loop_prefixpoint while_mult_increasing while_mult_transitive while_one_while)
  have "x  (y  z)  x  ((x  1) * (y  z))"
    by (metis mult_left_isotone mult_left_one while_increasing while_right_isotone)
  also have "...  (x  1) * ((x  y)  (y  z))  (x  bot)"
    using 1 while_simulate_left_plus_1 by auto
  also have "...  (x  1) * ((x  y)  z)  (x  z)"
    by (simp add: le_supI1 sup_commute while_absorb_2 while_increasing while_right_isotone)
  also have "... = (x  1) * z  (x  1) * (x  y) * ((x  y)  z)  (x  z)"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "... = (x  y) * ((x  y)  z)  (x  z)"
    by (smt sup_assoc sup_commute le_iff_sup mult_left_one mult_right_dist_sup order_refl while_absorb_1 while_plus_one while_sub_associative)
  also have "...  ((x  y)  z)  (x  z)"
    using sup_left_isotone while_left_plus_below by auto
  finally show ?thesis
    .
qed

lemma while_induct:
  "x * z  z  y  z  x  1  z  x  y  z"
  by (metis le_supI1 sup_commute sup_bot_left le_iff_sup while_right_isotone while_simulate_absorb)

(*
lemma while_sumstar_4_below: "(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)" oops
lemma while_sumstar_2: "(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)" oops
lemma while_sumstar_3: "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)" oops
lemma while_decompose_6: "x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)" oops
lemma while_finite_associative: "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)" oops
lemma atomicity_refinement: "s = s * q ⟹ x = q * x ⟹ q * b = bot ⟹ r * b ≤ b * r ⟹ r * l ≤ l * r ⟹ x * l ≤ l * x ⟹ b * l ≤ l * b ⟹ q * l ≤ l * q ⟹ r ⋆ q ≤ q * (r ⋆ 1) ⟹ q ≤ 1 ⟹ s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)" oops

lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
*)

end

class bounded_binary_itering = bounded_idempotent_left_zero_semiring + binary_itering
begin

text ‹Theorem 9›

lemma while_right_top:
  "x  top = top"
  by (metis sup_left_top while_left_unfold)

text ‹Theorem 9›

lemma while_left_top:
  "top * (x  1) = top"
  by (meson order.antisym le_supE top_greatest while_back_loop_prefixpoint)

end

class extended_binary_itering = binary_itering +
  assumes while_denest_0: "w * (x  (y * z))  (w * (x  y))  (w * (x  y) * z)"
begin

text ‹Theorem 10.2›

lemma while_denest_1:
  "w * (x  (y * z))  (w * (x  y))  z"
  using while_denest_0 while_mult_increasing while_mult_transitive by blast

lemma while_mult_sub_while_while:
  "x  (y * z)  (x  y)  z"
  by (metis mult_left_one while_denest_1)

lemma while_zero_zero:
  "(x  bot)  bot = x  bot"
  by (metis order.antisym mult_left_zero sup_bot_left while_left_unfold while_sub_associative while_mult_sub_while_while)

text ‹Theorem 10.11›

lemma while_mult_zero_zero:
  "(x * (y  bot))  bot = x * (y  bot)"
  apply (rule order.antisym)
  apply (metis sup_bot_left while_left_unfold mult_assoc le_supI1 mult_left_zero mult_right_isotone while_left_dist_sup while_sub_associative)
  by (metis mult_left_zero while_denest_1)

text ‹Theorem 10.3›

lemma while_denest_2:
  "w * ((x  (y * w))  z) = w * (((x  y) * w)  z)"
  apply (rule order.antisym)
  apply (metis mult_assoc while_denest_0 while_simulate_right_plus_1 while_slide)
  by (simp add: mult_isotone while_left_isotone while_sub_associative)

text ‹Theorem 10.12›

lemma while_denest_3:
  "(x  w)  (x  bot) = (x  w)  bot"
  by (metis while_absorb_2 while_right_isotone while_zero_zero bot_least)

text ‹Theorem 10.15›

lemma while_02:
  "x  ((x  w)  ((x  y) * z)) = (x  w)  ((x  y) * z)"
proof -
  have "x * ((x  w)  ((x  y) * z)) = x * (x  y) * z  x * (x  w) * ((x  w)  ((x  y) * z))"
    by (metis mult_assoc mult_left_dist_sup while_left_unfold)
  also have "...  (x  w)  ((x  y) * z)"
    by (metis sup_mono mult_right_sub_dist_sup_right while_left_unfold)
  finally have "x  ((x  w)  ((x  y) * z))  ((x  w)  ((x  y) * z))  (x  bot)"
    using while_simulate_absorb by auto
  also have "... = (x  w)  ((x  y) * z)"
    by (metis sup_commute le_iff_sup order_trans while_mult_sub_while_while while_right_isotone bot_least)
  finally show ?thesis
    by (simp add: order.antisym while_increasing)
qed

lemma while_sumstar_3_below:
  "(x  y)  (x  z)  (x  y)  ((x  1) * z)"
proof -
  have "(x  y)  (x  z) = (x  z)  ((x  y)  ((x  y) * (x  z)))"
    using while_right_unfold by blast
  also have "...  (x  z)  ((x  y)  (x  (y * (x  z))))"
    by (meson sup_right_isotone while_right_isotone while_sub_associative)
  also have "...  (x  z)  ((x  y)  (x  ((x  y)  (x  z))))"
    by (smt sup_right_isotone order_trans while_increasing while_mult_upper_bound while_one_increasing while_right_isotone)
  also have "...  (x  z)  ((x  y)  (x  ((x  y)  ((x  1) * z))))"
    by (metis sup_right_isotone mult_left_isotone mult_left_one order_trans while_increasing while_right_isotone while_sumstar while_transitive)
  also have "... = (x  z)  ((x  y)  ((x  1) * z))"
    by (simp add: while_transitive while_02)
  also have "... = (x  y)  ((x  1) * z)"
    by (smt sup_assoc mult_left_one mult_right_dist_sup while_02 while_left_dist_sup while_plus_one)
  finally show ?thesis
    .
qed

lemma while_sumstar_4_below:
  "(x  y)  ((x  1) * z)  x  ((y * (x  1))  z)"
proof -
  have "(x  y)  ((x  1) * z) = (x  1) * z  (x  y) * ((x  y)  ((x  1) * z))"
    using while_left_unfold by auto
  also have "...  (x  z)  (x  (y * ((x  y)  ((x  1) * z))))"
    by (meson sup_mono while_one_mult_below while_sub_associative)
  also have "... = (x  z)  (x  (y * (((x  1) * y)  ((x  1) * z))))"
    by (metis mult_left_one while_denest_2)
  also have "... = x  ((y * (x  1))  z)"
    by (metis while_left_dist_sup while_productstar)
  finally show ?thesis
    .
qed

text ‹Theorem 10.10›

lemma while_sumstar_1:
  "(x  y)  z = (x  y)  ((x  1) * z)"
  by (smt order.eq_iff order_trans while_sup_1_below while_sumstar while_sumstar_3_below while_sumstar_4_below)

text ‹Theorem 10.8›

lemma while_sumstar_2:
  "(x  y)  z = x  ((y * (x  1))  z)"
  using order.antisym while_sup_1_below while_sumstar_1 while_sumstar_4_below by auto

text ‹Theorem 10.9›

lemma while_sumstar_3:
  "(x  y)  z = ((x  1) * y)  (x  z)"
  using order.antisym while_sumstar while_sumstar_1_below while_sumstar_2_below while_sumstar_2 by force

text ‹Theorem 10.6›

lemma while_decompose_6:
  "x  ((y * (x  1))  z) = y  ((x * (y  1))  z)"
  by (metis sup_commute while_sumstar_2)

text ‹Theorem 10.4›

lemma while_denest_4:
  "(x  w)  (x  (y * z)) = (x  w)  ((x  y) * z)"
proof -
  have "(x  w)  (x  (y * z)) = x  ((w * (x  1))  (y * z))"
    using while_sumstar while_sumstar_2 by force
  also have "...  (x  w)  ((x  y) * z)"
    by (metis while_01 while_right_isotone while_02)
  finally show ?thesis
    using order.antisym while_right_isotone while_sub_associative by auto
qed

text ‹Theorem 10.13›

lemma while_denest_5:
  "w * ((x  (y * w))  (x  (y * z))) = w * (((x  y) * w)  ((x  y) * z))"
  by (simp add: while_denest_2 while_denest_4)

text ‹Theorem 10.5›

lemma while_denest_6:
  "(w * (x  y))  z = z  w * ((x  y * w)  (y * z))"
  by (metis while_denest_5 while_productstar while_sumstar)

text ‹Theorem 10.1›

lemma while_sum_below_one:
  "y * ((x  y)  z)  (y * (x  1))  z"
  by (simp add: while_denest_6)

text ‹Theorem 10.14›

lemma while_separate_unfold:
  "(y * (x  1))  z = (y  z)  (y  (y * x * (x  ((y * (x  1))  z))))"
proof -
  have "y  (y * x * (x  ((y * (x  1))  z)))  y  (y * ((x  y)  z))"
    using mult_right_isotone while_left_plus_below while_right_isotone mult_assoc while_sumstar_2 by auto
  also have "...  (y * (x  1))  z"
    by (metis sup_commute sup_ge1 while_absorb_1 while_mult_star_exchange while_sum_below_one)
  finally have "(y  z)  (y  (y * x * (x  ((y * (x  1))  z))))  (y * (x  1))  z"
    using sup.bounded_iff while_back_loop_prefixpoint while_left_isotone by auto
  thus ?thesis
    by (simp add: order.antisym while_separate_unfold_below)
qed

text ‹Theorem 10.7›

lemma while_finite_associative:
  "x  bot = bot  (x  y) * z = x  (y * z)"
  by (metis while_denest_4 while_zero)

text ‹Theorem 12›

lemma atomicity_refinement:
  assumes "s = s * q"
      and "x = q * x"
      and "q * b = bot"
      and "r * b  b * r"
      and "r * l  l * r"
      and "x * l  l * x"
      and "b * l  l * b"
      and "q * l  l * q"
      and "r  q  q * (r  1)  q  1"
    shows "s * ((x  b  r  l)  (q * z))  s * ((x * (b  q)  r  l)  z)"
proof -
  have 1: "(x  b  r) * l  l * (x  b  r)"
    by (smt assms(5-7) mult_left_dist_sup semiring.add_mono semiring.distrib_right)
  have "q * ((x * (b  r  1) * q)  z)  (x * (b  r  1) * q)  z"
    using assms(9) order_lesseq_imp while_increasing while_mult_upper_bound by blast
  also have "...  (x * (b  ((r  1) * q)))  z"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative mult_assoc)
  also have "...  (x * (b  r  q))  z"
    by (simp add: mult_right_isotone while_left_isotone while_one_mult_below while_right_isotone)
  also have "...  (x * (b  (q * (r  1))))  z"
    by (simp add: assms(9) mult_right_isotone while_left_isotone while_right_isotone)
  finally have 2: "q * ((x * (b  r  1) * q)  z)  (x * (b  q) * (r  1))  z"
    using while_associative_while_1 mult_assoc by auto
  have "s * ((x  b  r  l)  (q * z)) = s * (l  (x  b  r)  (q * z))"
    using 1 sup_commute while_separate_1 by fastforce
  also have "... = s * q * (l  b  r  (q * x * (b  r  1))  (q * z))"
    by (smt assms(1,2,4) sup_assoc sup_commute while_sumstar_2 while_separate_1)
  also have "... = s * q * (l  b  r  (q * ((x * (b  r  1) * q)  z)))"
    by (simp add: while_slide mult_assoc)
  also have "...  s * q * (l  b  r  (x * (b  q) * (r  1))  z)"
    using 2 by (meson mult_right_isotone while_right_isotone)
  also have "...  s * (l  q * (b  r  (x * (b  q) * (r  1))  z))"
    by (simp add: assms(8) mult_right_isotone while_simulate mult_assoc)
  also have "... = s * (l  q * (r  (x * (b  q) * (r  1))  z))"
    using assms(3) while_elimination by auto
  also have "...  s * (l  r  (x * (b  q) * (r  1))  z)"
    by (meson assms(9) order.trans mult_right_isotone order.refl while_increasing while_mult_upper_bound while_right_isotone)
  also have "... = s * (l  (r  x * (b  q))  z)"
    by (simp add: while_sumstar_2)
  also have "...  s * ((x * (b  q)  r  l)  z)"
    using mult_right_isotone sup_commute while_sub_dist_3 by auto
  finally show ?thesis
    .
qed

end

class bounded_extended_binary_itering = bounded_binary_itering + extended_binary_itering

end

Theory Binary_Iterings_Strict

(* Title:      Strict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Strict Binary Iterings›

theory Binary_Iterings_Strict

imports Stone_Kleene_Relation_Algebras.Iterings Binary_Iterings

begin

class strict_itering = itering + while +
  assumes while_def: "x  y = x * y"
begin

text ‹Theorem 8.1›

subclass extended_binary_itering
  apply unfold_locales
  apply (metis circ_loop_fixpoint circ_slide_1 sup_commute while_def mult_assoc)
  apply (metis circ_sup mult_assoc while_def)
  apply (simp add: mult_left_dist_sup while_def)
  apply (simp add: while_def mult_assoc)
  apply (metis circ_simulate_left_plus mult_assoc mult_left_isotone mult_right_dist_sup mult_1_right while_def)
  apply (metis circ_simulate_right_plus mult_assoc mult_left_isotone mult_right_dist_sup while_def)
  by (metis circ_loop_fixpoint mult_right_sub_dist_sup_right while_def mult_assoc)

text ‹Theorem 13.1›

lemma while_associative:
  "(x  y) * z = x  (y * z)"
  by (simp add: while_def mult_assoc)

text ‹Theorem 13.3›

lemma while_one_mult:
  "(x  1) * x = x  x"
  by (simp add: while_def)

lemma while_back_loop_is_fixpoint:
  "is_fixpoint (λx . x * y  z) (z * (y  1))"
  by (simp add: circ_back_loop_is_fixpoint while_def)

text ‹Theorem 13.4›

lemma while_sumstar_var:
  "(x  y)  z = ((x  1) * y)  ((x  1) * z)"
  by (simp add: while_sumstar_3 while_associative)

text ‹Theorem 13.2›

lemma while_mult_1_assoc:
  "(x  1) * y = x  y"
  by (simp add: while_def)

(*
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
*)

end

class bounded_strict_itering = bounded_itering + strict_itering
begin

subclass bounded_extended_binary_itering ..

text ‹Theorem 13.6›

lemma while_top_2:
  "top  z = top * z"
  by (simp add: circ_top while_def)

text ‹Theorem 13.5›

lemma while_mult_top_2:
  "(x * top)  z = z  x * top * z"
  by (metis circ_left_top mult_assoc while_def while_left_unfold)

text ‹Theorem 13 counterexamples›

(*
lemma while_one_top: "1 ⋆ x = top" nitpick [expect=genuine,card=2] oops
lemma while_top: "top ⋆ x = top" nitpick [expect=genuine,card=2] oops
lemma while_sub_mult_one: "x * (1 ⋆ y) ≤ 1 ⋆ x" oops
lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" oops
lemma while_unfold_below: "x = z ⊔ y * x ⟹ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_unfold_below: "x ≤ z ⊔ y * x ⟹ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=2] oops
lemma tarski_mult_top_idempotent: "x * top = x * top * x * top" oops

lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_sub_while_zero: "x ⋆ z ≤ (x ⋆ y) ⋆ z" oops
lemma while_while_sub_associative: "x ⋆ (y ⋆ z) ≤ (x ⋆ y) ⋆ z" oops
lemma tarski: "x ≤ x * top * x * top" oops
lemma tarski_top_omega_below: "x * top ≤ (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski_top_omega: "x * top = (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski_below_top_omega: "x ≤ (x * top) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma tarski: "x = bot ∨ top * x * top = top" oops
lemma "1 = (x * bot) ⋆ 1" oops
lemma "1 ⊔ x * bot = x ⋆ 1" oops
lemma "x = x * (x ⋆ 1)" oops
lemma "x * (x ⋆ 1) = x ⋆ 1" oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" oops
lemma "y * x = x ⟹ y ⋆ x ≤ x" oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" oops
*)

end

class binary_itering_unary = extended_binary_itering + circ +
  assumes circ_def: "x = x  1"
begin

text ‹Theorem 50.7›

subclass left_conway_semiring
  apply unfold_locales
  using circ_def while_left_unfold apply simp
  apply (metis circ_def mult_1_right while_one_mult_below while_slide)
  using circ_def while_one_while while_sumstar_2 by auto

end

class strict_binary_itering = binary_itering + circ +
  assumes while_associative: "(x  y) * z = x  (y * z)"
  assumes circ_def: "x = x  1"
begin

text ‹Theorem 2.8›

subclass itering
  apply unfold_locales
  apply (simp add: circ_def while_associative while_sumstar)
  apply (metis circ_def mult_1_right while_associative while_productstar while_slide)
  apply (metis circ_def mult_1_right while_associative mult_1_left while_slide while_simulate_right_plus)
  by (metis circ_def mult_1_right while_associative mult_1_left while_simulate_left_plus mult_right_dist_sup)

text ‹Theorem 8.5›

subclass extended_binary_itering
  apply unfold_locales
  by (simp add: while_associative while_increasing mult_assoc)

end

end

Theory Binary_Iterings_Nonstrict

(* Title:      Nonstrict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Nonstrict Binary Iterings›

theory Binary_Iterings_Nonstrict

imports Omega_Algebras Binary_Iterings

begin

class nonstrict_itering = bounded_left_zero_omega_algebra + while +
  assumes while_def: "x  y = xω  x * y"
begin

text ‹Theorem 8.2›

subclass bounded_binary_itering
proof (unfold_locales)
  fix x y z
  show "(x * y)  z = z  x * ((y * x)  (y * z))"
    by (metis sup_commute mult_assoc mult_left_dist_sup omega_loop_fixpoint omega_slide star.circ_slide while_def)
next
  fix x y z
  show "(x  y)  z = (x  y)  (x  z)"
  proof -
    have 1: "(x  y)  z = (x * y)ω  (x * y) * (xω  x * z)"
      using mult_left_dist_sup omega_decompose star.circ_sup_9 sup_assoc while_def mult_assoc by auto
    hence 2: "(x  y)  z  (x  y)  (x  z)"
      by (smt sup_mono sup_ge2 le_iff_sup mult_left_isotone omega_sub_dist star.circ_sub_dist while_def)
    let ?rhs = "x * y * ((xω  x * y)ω  (xω  x * y) * (xω  x * z))  (xω  x * z)"
    have "xω * (xω  x * y)ω  xω"
      by (simp add: omega_sub_vector)
    hence "xω * (xω  x * y)ω  x * y * (xω  x * y)ω  ?rhs"
      by (smt sup_commute sup_mono sup_ge1 mult_left_dist_sup order_trans)
    hence 3: "(xω  x * y)ω  ?rhs"
      by (metis mult_right_dist_sup omega_unfold)
    have "xω * (xω  x * y) * (xω  x * z)  xω"
      by (simp add: omega_mult_star_2 omega_sub_vector)
    hence "xω * (xω  x * y) * (xω  x * z)  x * y * (xω  x * y) * (xω  x * z)  ?rhs"
      by (smt sup_commute sup_mono sup_ge2 mult_assoc mult_left_dist_sup order_trans)
    hence "(xω  x * y) * (xω  x * z)  ?rhs"
      by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_loop_fixpoint)
    hence "(xω  x * y)ω  (xω  x * y) * (xω  x * z)  ?rhs"
      using 3 by simp
    hence "(xω  x * y)ω  (xω  x * y) * (xω  x * z)  (x * y)ω  (x * y) * (xω  x * z)"
      by (metis sup_commute omega_induct)
    thus ?thesis
      using 1 2 order.antisym while_def by force
  qed
next
  fix x y z
  show "x  (y  z) = (x  y)  (x  z)"
    using mult_left_dist_sup sup_assoc sup_commute while_def by auto
next
  fix x y z
  show "(x  y) * z  x  (y * z)"
    using mult_semi_associative omega_sub_vector semiring.add_mono semiring.distrib_right while_def by fastforce
next
  fix v w x y z
  show "x * z  z * (y  1)  w  x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
  proof
    assume "x * z  z * (y  1)  w"
    hence 1: "x * z  z * yω  z * y  w"
      by (metis mult_left_dist_sup mult_1_right while_def)
    let ?rhs = "z * (yω  y * v)  xω  x * w * (yω  y * v)"
    have 2: "z * v  ?rhs"
      by (metis le_supI1 mult_left_sub_dist_sup_right omega_loop_fixpoint)
    have "x * z * (yω  y * v)  ?rhs"
    proof -
      have "x * z * (yω  y * v)  (z * yω  z * y  w) * (yω  y * v)"
        using 1 mult_left_isotone by auto
      also have "... = z * (yω * (yω  y * v)  y * (yω  y * v))  w * (yω  y * v)"
        by (smt mult_assoc mult_left_dist_sup mult_right_dist_sup)
      also have "... = z * (yω * (yω  y * v)  yω  y * v)  w * (yω  y * v)"
        by (smt sup_assoc mult_assoc mult_left_dist_sup star.circ_transitive_equal star_mult_omega)
      also have "...  z * (yω  y * v)  x * w * (yω  y * v)"
        by (smt sup_commute sup_mono sup_left_top mult_left_dist_sup mult_left_one mult_right_dist_sup mult_right_sub_dist_sup_left omega_vector order_refl star.circ_plus_one)
      finally show ?thesis
        by (smt sup_assoc sup_commute le_iff_sup)
    qed
    hence "x * ?rhs  ?rhs"
      by (smt sup_assoc sup_commute sup_ge1 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup omega_unfold star.circ_increasing star.circ_transitive_equal)
    hence "z * v  x * ?rhs  ?rhs"
      using 2 le_supI by blast
    hence "x * z * v  ?rhs"
      by (simp add: star_left_induct mult_assoc)
    hence "xω  x * z * v  ?rhs"
      by (meson order_trans sup_ge1 sup_ge2 sup_least)
    thus "x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
      by (simp add: sup_assoc while_def mult_assoc)
  qed
next
  fix v w x y z
  show "z * x  y * (y  z)  w  z * (x  v)  y  (z * v  w * (x  v))"
  proof
    assume "z * x  y * (y  z)  w"
    hence "z * x  y * (yω  y * z)  w"
      by (simp add: while_def)
    hence 1: "z * x  yω  y * y * z  w"
      using mult_left_dist_sup omega_unfold mult_assoc by auto
    let ?rhs = "yω  y * z * v  y * w * (xω  x * v)"
    have 2: "z * xω  ?rhs"
    proof -
      have "z * xω  y * y * z * xω  yω * xω  w * xω"
        using 1 by (smt sup_commute le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
      also have "...  y * y * z * xω  yω  w * xω"
        using omega_sub_vector semiring.add_mono by blast
      also have "... = y * y * (z * xω)  (yω  w * xω)"
        by (simp add: sup_assoc mult_assoc)
      finally have "z * xω  (y * y)ω  (y * y) * (yω  w * xω)"
        by (simp add: omega_induct sup_commute)
      also have "... = yω  y * w * xω"
        by (simp add: left_plus_omega semiring.distrib_left star.left_plus_circ star_mult_omega mult_assoc)
      also have "...  ?rhs"
        using mult_left_sub_dist_sup_left sup.mono sup_ge1 by blast
      finally show ?thesis
        .
    qed
    let ?rhs2 = "yω  y * z  y * w * (xω  x)"
    have "?rhs2 * x  ?rhs2"
    proof -
      have 3: "yω * x  ?rhs2"
        by (simp add: le_supI1 omega_sub_vector)
      have "y * z * x  y * (yω  y * y * z  w)"
        using 1 mult_right_isotone mult_assoc by auto
      also have "... = yω  y * y * y * z  y * w"
        by (simp add: semiring.distrib_left star_mult_omega mult_assoc)
      also have "... = yω  y * y * z  y * w"
        by (simp add: star.circ_plus_same star.circ_transitive_equal mult_assoc)
      also have "...  yω  y * z  y * w"
        by (metis sup_left_isotone sup_right_isotone mult_left_isotone star.left_plus_below_circ)
      also have "...  yω  y * z  y * w * x"
        using semiring.add_left_mono star.circ_back_loop_prefixpoint by auto
      finally have 4: "y * z * x  ?rhs2"
        using mult_left_sub_dist_sup_right order_lesseq_imp semiring.add_left_mono by blast
      have "(xω  x) * x  xω  x"
        using omega_sub_vector semiring.distrib_right star.left_plus_below_circ star_plus sup_mono by fastforce
      hence "y * w * (xω  x) * x  ?rhs2"
        by (simp add: le_supI2 mult_right_isotone mult_assoc)
      thus ?thesis
        using 3 4 mult_right_dist_sup by force
    qed
    hence "z  ?rhs2 * x  ?rhs2"
      by (metis omega_loop_fixpoint sup.boundedE sup_ge1 sup_least)
    hence 5: "z * x  ?rhs2"
      using star_right_induct by blast
    have "z * x * v  ?rhs"
    proof -
      have "z * x * v  ?rhs2 * v"
        using 5 mult_left_isotone by auto
      also have "... = yω * v  y * z * v  y * w * (xω * v  x * v)"
        using mult_right_dist_sup mult_assoc by auto
      also have "...  yω  y * z * v  y * w * (xω * v  x * v)"
        using omega_sub_vector semiring.add_right_mono by blast
      also have "...  ?rhs"
        using mult_right_isotone omega_sub_vector semiring.add_left_mono semiring.add_right_mono by auto
      finally show ?thesis
        .
    qed
    hence "z * (xω  x * v)  ?rhs"
      using 2 semiring.distrib_left mult_assoc by force
    thus "z * (x  v)  y  (z * v  w * (x  v))"
      by (simp add: semiring.distrib_left sup_assoc while_def mult_assoc)
  qed
qed

text ‹Theorem 13.8›

lemma while_top:
  "top  x = top"
  by (metis sup_left_top star.circ_top star_omega_top while_def)

text ‹Theorem 13.7›

lemma while_one_top:
  "1  x = top"
  by (simp add: omega_one while_def)

lemma while_finite_associative:
  "xω = bot  (x  y) * z = x  (y * z)"
  by (simp add: while_def mult_assoc)

lemma star_below_while:
  "x * y  x  y"
  by (simp add: while_def)

text ‹Theorem 13.9›

lemma while_sub_mult_one:
  "x * (1  y)  1  x"
  by (simp add: omega_one while_def)

lemma while_while_one:
  "y  (x  1) = yω  y * xω  y * x"
  using mult_left_dist_sup sup_assoc while_def by auto

lemma while_simulate_4_plus:
  assumes "y * x  x * (x  (1  y))"
    shows "y * x * x  x * (x  (1  y))"
proof -
  have 1: "x * (x  (1  y)) = xω  x * x  x * x * y"
    using mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by force
  hence "y * x * x  (xω  x * x  x * x * y) * x"
    using assms mult_left_isotone by auto
  also have "... = xω * x  x * x * x  x * x * y * x"
    using mult_right_dist_sup by force
  also have "... = x * x * (y * x * x)  xω  x * x  x * x * y"
    by (smt sup_assoc sup_commute mult_assoc omega_mult_star_2 star.circ_back_loop_fixpoint star.circ_plus_same star.circ_transitive_equal)
  finally have "y * x * x  x * x * (y * x * x)  (xω  x * x  x * x * y)"
    using sup_assoc by force
  hence "y * x * x  (x * x)ω  (x * x) * (xω  x * x  x * x * y)"
    by (simp add: omega_induct sup_monoid.add_commute)
  also have "... = xω  x * (xω  x * x  x * x * y)"
    by (simp add: left_plus_omega star.left_plus_circ)
  finally show ?thesis
    using 1 by (metis while_def while_mult_star_exchange while_transitive)
qed

lemma while_simulate_4_omega:
  assumes "y * x  x * (x  (1  y))"
    shows "y * xω  xω"
proof -
  have "x * (x  (1  y)) = xω  x * x  x * x * y"
    using mult_1_right mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by auto
  hence "y * xω  (xω  x * x  x * x * y) * xω"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "... = xω * xω  x * x * xω  x * x * y * xω"
    using semiring.distrib_right by auto
  also have "... = x * x * (y * xω)  xω"
    by (metis sup_commute le_iff_sup mult_assoc omega_sub_vector omega_unfold star_mult_omega)
  finally have "y * xω  x * x * (y * xω)  xω"
    .
  hence "y * xω  (x * x)ω  (x * x) * xω"
    by (simp add: omega_induct sup_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

text ‹Theorem 13.11›

lemma while_unfold_below:
  "x = z  y * x  x  y  z"
  by (simp add: omega_induct while_def)

text ‹Theorem 13.12›

lemma while_unfold_below_sub:
  "x  z  y * x  x  y  z"
  by (simp add: omega_induct while_def)

text ‹Theorem 13.10›

lemma while_unfold_below_1:
  "x = y * x  x  y  1"
  by (simp add: while_unfold_below_sub)

lemma while_square_1:
  "x  1 = (x * x)  (x  1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x  x  y  x  1  x"
  by (simp add: while_unfold_below_sub)

lemma while_loop_is_greatest_postfixpoint:
  "is_greatest_postfixpoint (λx . y * x  z) (y  z)"
proof -
  have "(y  z)  (λx . y * x  z) (y  z)"
    using sup_commute while_left_unfold by force
  thus ?thesis
    by (simp add: is_greatest_postfixpoint_def sup_commute while_unfold_below_sub)
qed

lemma while_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (λx . y * x  z) (y  z)"
  by (simp add: omega_loop_is_greatest_fixpoint while_def)

(*
lemma while_sumstar_4_below: "(x ⋆ y) ⋆ ((x ⋆ 1) * z) ≤ x ⋆ ((y * (x ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_sumstar_2: "(x ⊔ y) ⋆ z = x ⋆ ((y * (x ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_sumstar_3: "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ (x ⋆ z)" oops
lemma while_decompose_6: "x ⋆ ((y * (x ⋆ 1)) ⋆ z) = y ⋆ ((x * (y ⋆ 1)) ⋆ z)" nitpick [expect=genuine,card=6] oops
lemma while_finite_associative: "x ⋆ bot = bot ⟹ (x ⋆ y) * z = x ⋆ (y * z)" oops
lemma atomicity_refinement: "s = s * q ⟹ x = q * x ⟹ q * b = bot ⟹ r * b ≤ b * r ⟹ r * l ≤ l * r ⟹ x * l ≤ l * x ⟹ b * l ≤ l * b ⟹ q * l ≤ l * q ⟹ r ⋆ q ≤ q * (r ⋆ 1) ⟹ q ≤ 1 ⟹ s * ((x ⊔ b ⊔ r ⊔ l) ⋆ (q * z)) ≤ s * ((x * (b ⋆ q) ⊔ r ⊔ l) ⋆ z)" oops

lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops

lemma while_mult_sub_while_while: "x ⋆ (y * z) ≤ (x ⋆ y) ⋆ z" oops
lemma while_zero_zero: "(x ⋆ bot) ⋆ bot = x ⋆ bot" oops
lemma while_denest_3: "(x ⋆ w) ⋆ (x ⋆ bot) = (x ⋆ w) ⋆ bot" oops
lemma while_02: "x ⋆ ((x ⋆ w) ⋆ ((x ⋆ y) * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)" oops
lemma while_sumstar_3_below: "(x ⋆ y) ⋆ (x ⋆ z) ≤ (x ⋆ y) ⋆ ((x ⋆ 1) * z)" oops
lemma while_sumstar_1: "(x ⊔ y) ⋆ z = (x ⋆ y) ⋆ ((x ⋆ 1) * z)" oops
lemma while_denest_4: "(x ⋆ w) ⋆ (x ⋆ (y * z)) = (x ⋆ w) ⋆ ((x ⋆ y) * z)" oops
*)

end

class nonstrict_itering_zero = nonstrict_itering +
  assumes mult_right_zero: "x * bot = bot"
begin

lemma while_finite_associative_2:
  "x  bot = bot  (x  y) * z = x  (y * z)"
  by (metis sup_bot_left sup_bot_right mult_assoc mult_right_zero while_def)

text ‹Theorem 13 counterexamples›

(*
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_top_idempotent: "x * top = x * top * x * top" nitpick [expect=genuine,card=3] oops

lemma while_denest_0: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ (w * (x ⋆ y) * z)" nitpick [expect=genuine,card=3] oops
lemma while_denest_1: "w * (x ⋆ (y * z)) ≤ (w * (x ⋆ y)) ⋆ z" nitpick [expect=genuine,card=3] oops
lemma while_mult_zero_zero: "(x * (y ⋆ bot)) ⋆ bot = x * (y ⋆ bot)" nitpick [expect=genuine,card=3] oops
lemma while_denest_2: "w * ((x ⋆ (y * w)) ⋆ z) = w * (((x ⋆ y) * w) ⋆ z)" nitpick [expect=genuine,card=3] oops
lemma while_denest_5: "w * ((x ⋆ (y * w)) ⋆ (x ⋆ (y * z))) = w * (((x ⋆ y) * w) ⋆ ((x ⋆ y) * z))" nitpick [expect=genuine,card=3] oops
lemma while_denest_6: "(w * (x ⋆ y)) ⋆ z = z ⊔ w * ((x ⊔ y * w) ⋆ (y * z))" nitpick [expect=genuine,card=3] oops
lemma while_sum_below_one: "y * ((x ⊔ y) ⋆ z) ≤ (y * (x ⋆ 1)) ⋆ z" nitpick [expect=genuine,card=3] oops
lemma while_separate_unfold: "(y * (x ⋆ 1)) ⋆ z = (y ⋆ z) ⊔ (y ⋆ (y * x * (x ⋆ ((y * (x ⋆ 1)) ⋆ z))))" nitpick [expect=genuine,card=3] oops

lemma while_sub_while_zero: "x ⋆ z ≤ (x ⋆ y) ⋆ z" nitpick [expect=genuine,card=4] oops
lemma while_while_sub_associative: "x ⋆ (y ⋆ z) ≤ (x ⋆ y) ⋆ z" nitpick [expect=genuine,card=4] oops
lemma tarski: "x ≤ x * top * x * top" nitpick [expect=genuine,card=3] oops
lemma tarski_top_omega_below: "x * top ≤ (x * top)ω" nitpick [expect=genuine,card=3] oops
lemma tarski_top_omega: "x * top = (x * top)ω" nitpick [expect=genuine,card=3] oops
lemma tarski_below_top_omega: "x ≤ (x * top)ω" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_omega_omega: "(x * yω)ω = x * yω" nitpick [expect=genuine,card=3] oops
lemma tarski_mult_omega_omega: "(∀z . zωω = zω) ⟹ (x * yω)ω = x * yω" nitpick [expect=genuine,card=3] oops
lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
*)

end

class nonstrict_itering_tarski = nonstrict_itering +
  assumes tarski: "x  x * top * x * top"
begin

text ‹Theorem 13.14›

lemma tarski_mult_top_idempotent:
  "x * top = x * top * x * top"
  by (metis sup_commute le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_left_top tarski top_mult_top)

lemma tarski_top_omega_below:
  "x * top  (x * top)ω"
  using omega_induct_mult order.refl mult_assoc tarski_mult_top_idempotent by auto

lemma tarski_top_omega:
  "x * top = (x * top)ω"
  by (simp add: order.eq_iff mult_top_omega tarski_top_omega_below)

lemma tarski_below_top_omega:
  "x  (x * top)ω"
  using top_right_mult_increasing tarski_top_omega by auto

lemma tarski_mult_omega_omega:
  "(x * yω)ω = x * yω"
  by (metis mult_assoc omega_vector tarski_top_omega)

lemma tarski_omega_idempotent:
  "xωω = xω"
  by (metis omega_vector tarski_top_omega)

lemma while_denest_2a:
  "w * ((x  (y * w))  z) = w * (((x  y) * w)  z)"
proof -
  have "(xω  x * y * w)ω = (x * y * w) * xω * (((x * y * w) * xω)ω  ((x * y * w) * xω) * (x * y * w)ω)  (x * y * w)ω"
    by (metis sup_commute omega_decompose omega_loop_fixpoint)
  also have "...  (x * y * w) * xω  (x * y * w)ω"
    by (metis sup_left_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have 1: "w * (xω  x * y * w)ω  (w * x * y) * w * xω  (w * x * y)ω"
    by (smt sup_commute le_iff_sup mult_assoc mult_left_dist_sup while_def while_slide)
  have "(xω  x * y * w) * z = (x * y * w) * xω * ((x * y * w) * xω) * (x * y * w) * z  (x * y * w) * z"
    by (smt sup_commute mult_assoc star.circ_sup star.circ_loop_fixpoint)
  also have "...  (x * y * w) * xω  (x * y * w) * z"
    by (smt sup_commute sup_right_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have "w * (xω  x * y * w) * z  (w * x * y) * w * xω  (w * x * y) * w * z"
    by (metis mult_assoc mult_left_dist_sup mult_right_isotone star.circ_slide)
  hence "w * (xω  x * y * w)ω  w * (xω  x * y * w) * z  (w * x * y) * (w * xω)ω  (w * x * y)ω  (w * x * y) * w * z"
    using 1 by (smt sup_assoc sup_commute le_iff_sup mult_assoc tarski_mult_omega_omega)
  also have "...  (w * xω  w * x * y) * (w * xω  w * x * y)ω  (w * xω  w * x * y)ω  (w * xω  w * x * y) * w * z"
    by (metis sup_mono sup_ge1 sup_ge2 mult_isotone mult_left_isotone omega_isotone star.circ_isotone)
  also have "... = (w * xω  w * x * y)ω  (w * xω  w * x * y) * w * z"
    by (simp add: star_mult_omega)
  finally have "w * ((xω  x * y * w)ω  (xω  x * y * w) * z)  w * ((xω  x * y) * w)ω  w * ((xω  x * y) * w) * z"
    by (smt mult_assoc mult_left_dist_sup omega_slide star.circ_slide)
  hence 2: "w * ((x  (y * w))  z)  w * (((x  y) * w)  z)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  have "w * (((x  y) * w)  z)  w * ((x  (y * w))  z)"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative)
  thus ?thesis
    using 2 order.antisym by auto
qed

lemma while_denest_3:
  "(x  w)  xω = (x  w)ω"
proof -
  have 1: "(x  w)  xω = (x  w)ω  (x  w) * xωω"
    by (simp add: while_def tarski_omega_idempotent)
  also have "...  (x  w)ω  (x  w) * (xω  x * w)ω"
    using mult_right_isotone omega_sub_dist semiring.add_left_mono by blast
  also have "... = (x  w)ω"
    by (simp add: star_mult_omega while_def)
  finally show ?thesis
    using 1 by (simp add: sup.order_iff)
qed

lemma while_denest_4a:
  "(x  w)  (x  (y * z)) = (x  w)  ((x  y) * z)"
proof -
  have "(x  w)  (x  (y * z)) = (x  w)ω  ((x  w)  (x * y * z))"
    using while_def while_denest_3 while_left_dist_sup mult_assoc by auto
  also have "...  (x  w)ω  ((x  w)  ((x  y) * z))"
    using mult_right_sub_dist_sup_right order.refl semiring.add_mono while_def while_right_isotone by auto
  finally have 1: "(x  w)  (x  (y * z))  (x  w)  ((x  y) * z)"
    by (simp add: while_def)
  have "(x  w)  ((x  y) * z)  (x  w)  (x  (y * z))"
    by (simp add: while_right_isotone while_sub_associative)
  thus ?thesis
    using 1 order.antisym by auto
qed

text ‹Theorem 8.3›

subclass bounded_extended_binary_itering
  apply unfold_locales
  by (smt mult_assoc while_denest_2a while_denest_4a while_increasing while_slide)

text ‹Theorem 13.13›

lemma while_mult_top:
  "(x * top)  z = z  x * top"
proof -
  have 1: "z  x * top  (x * top)  z"
    by (metis le_supI sup_ge1 while_def while_increasing tarski_top_omega)
  have "(x * top)  z = z  x * top * ((x * top)  z)"
    using while_left_unfold by auto
  also have "...  z  x * top"
    using mult_right_isotone sup_right_isotone top_greatest mult_assoc by auto
  finally show ?thesis
    using 1 order.antisym by auto
qed

lemma tarski_top_omega_below_2:
  "x * top  (x * top)  bot"
  by (simp add: while_mult_top)

lemma tarski_top_omega_2:
  "x * top = (x * top)  bot"
  by (simp add: while_mult_top)

lemma tarski_below_top_omega_2:
  "x  (x * top)  bot"
  using top_right_mult_increasing tarski_top_omega_2 by auto

(*
lemma "1 = (x * bot) ⋆ 1" nitpick [expect=genuine,card=3] oops
*)

end

class nonstrict_itering_tarski_zero = nonstrict_itering_tarski + nonstrict_itering_zero
begin

lemma while_bot_1:
  "1 = (x * bot)  1"
  by (simp add: mult_right_zero while_zero)

text ‹Theorem 13 counterexamples›

(*
lemma while_associative: "(x ⋆ y) * z = x ⋆ (y * z)" nitpick [expect=genuine,card=2] oops
lemma "(x ⋆ 1) * y = x ⋆ y" nitpick [expect=genuine,card=2] oops
lemma while_one_mult: "(x ⋆ 1) * x = x ⋆ x" nitpick [expect=genuine,card=4] oops
lemma "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)" nitpick [expect=genuine,card=2] oops
lemma while_mult_top_2: "(x * top) ⋆ z = z ⊔ x * top * z" nitpick [expect=genuine,card=2] oops
lemma while_top_2: "top ⋆ z = top * z" nitpick [expect=genuine,card=2] oops

lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))" nitpick [expect=genuine,card=4] oops
lemma "1 ⊔ x * bot = x ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "x = x * (x ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "x * (x ⋆ 1) = x ⋆ 1" nitpick [expect=genuine,card=2] oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" nitpick [expect=genuine,card=2] oops
lemma "y * x = x ==> y ⋆ x ≤ x" nitpick [expect=genuine,card=2] oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" nitpick [expect=genuine,card=2] oops

lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma tarski_case: assumes t1: "x = bot ⟶ P x" and t2: "top * x * top = top ⟶ P x" shows "P x" nitpick [expect=genuine,card=3] oops
*)

end

end

Theory Tests

(* Title:      Tests
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Tests›

theory Tests

imports Subset_Boolean_Algebras.Subset_Boolean_Algebras Base

begin

context subset_boolean_algebra_extended
begin

sublocale sba_dual: subset_boolean_algebra_extended where uminus = uminus and sup = inf and minus = "λx y . -(-x  y)" and inf = sup and bot = top and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: inf_associative)
  apply (simp add: inf_commutative)
  using inf_cases_2 apply simp
  using inf_closed apply simp
  apply simp
  apply simp
  using sub_sup_closed sub_sup_demorgan apply simp
  apply simp
  apply (simp add: inf_commutative less_eq_inf)
  by (metis inf_commutative inf_idempotent inf_left_dist_sup sub_less_def sup_absorb sup_right_zero top_double_complement)

lemma strict_leq_def:
  "-x < -y  -x  -y  ¬ (-y  -x)"
  by (simp add: sba_dual.sba_dual.sub_less_def sba_dual.sba_dual.sub_less_eq_def)

lemma one_def:
  "top = -bot"
  by simp

end

class tests = times + uminus + one + ord + sup + bot +
  assumes sub_assoc: "-x * (-y * -z) = (-x * -y) * -z"
  assumes sub_comm: "-x * -y = -y * -x"
  assumes sub_compl: "-x = -(--x * -y) * -(--x * --y)"
  assumes sub_mult_closed: "-x * -y = --(-x * -y)"
  assumes the_bot_def: "bot = (THE x . (y . x = -y * --y))" (* define without imposing uniqueness *)
  assumes one_def: "1 = - bot"
  assumes sup_def: "-x  -y = -(--x * --y)"
  assumes leq_def: "-x  -y  -x * -y = -x"
  assumes strict_leq_def: "-x < -y  -x  -y  ¬ (-y  -x)"
begin

sublocale tests_dual: subset_boolean_algebra_extended where uminus = uminus and sup = times and minus = "λx y . -(-x * y)" and inf = sup and bot = 1 and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: sub_assoc)
  apply (simp add: sub_comm)
  apply (simp add: sub_compl)
  using sub_mult_closed apply simp
  apply (simp add: the_bot_def)
  apply (simp add: one_def the_bot_def)
  apply (simp add: sup_def)
  apply simp
  apply (simp add: leq_def sub_comm)
  by (simp add: leq_def strict_leq_def sub_comm)

sublocale sba: subset_boolean_algebra_extended where uminus = uminus and sup = sup and minus = "λx y . -(-x  y)" and inf = times and bot = bot and less_eq = less_eq and less = less and top = 1 ..

text ‹sets and sequences of tests›

definition test_set :: "'a set  bool"
  where "test_set A  xA . x = --x"

lemma mult_left_dist_test_set:
  "test_set A  test_set { -p * x | x . x  A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma mult_right_dist_test_set:
  "test_set A  test_set { x * -p | x . x  A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma sup_left_dist_test_set:
  "test_set A  test_set { -p  x | x . x  A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma sup_right_dist_test_set:
  "test_set A  test_set { x  -p | x . x  A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma test_set_closed:
  "A  B  test_set B  test_set A"
  using test_set_def by auto

definition test_seq :: "(nat  'a)  bool"
  where "test_seq t  n . t n = --t n"

lemma test_seq_test_set:
  "test_seq t  test_set { t n | n::nat . True }"
  using test_seq_def test_set_def by auto

definition nat_test :: "(nat  'a)  'a  bool"
  where "nat_test t s  (n . t n = --t n)  s = --s  (n . t n  s)  (x y . (n . t n * -x  -y)  s * -x  -y)"

lemma nat_test_seq:
  "nat_test t s  test_seq t"
  by (simp add: nat_test_def test_seq_def)

primrec pSum :: "(nat  'a)  nat  'a"
  where "pSum f 0 = bot"
      | "pSum f (Suc m) = pSum f m  f m"

lemma pSum_test:
  "test_seq t  pSum t m = --(pSum t m)"
  apply (induct m)
  apply simp
  by (smt pSum.simps(2) tests_dual.sba_dual.sub_sup_closed test_seq_def)

lemma pSum_test_nat:
  "nat_test t s  pSum t m = --(pSum t m)"
  by (metis nat_test_seq pSum_test)

lemma pSum_upper:
  "test_seq t  i<m  t i  pSum t m"
proof (induct m)
  show "test_seq t  i<0  t i  pSum t 0"
    by (smt less_zeroE)
next
  fix n
  assume "test_seq t  i<n  t i  pSum t n"
  hence "test_seq t  i<n  t i  pSum t (Suc n)"
    by (smt (z3) pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_left tests_dual.transitive test_seq_def)
  thus "test_seq t  i<Suc n  t i  pSum t (Suc n)"
    by (metis less_Suc_eq pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_right test_seq_def)
qed

lemma pSum_below:
  "test_seq t  (m<k . t m * -p  -q)  pSum t k * -p  -q"
  apply (induct k)
  apply (simp add: tests_dual.top_greatest)
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_dist_inf pSum.simps(2) pSum_test test_seq_def sub_mult_closed less_Suc_eq tests_dual.sba_dual.sub_associative tests_dual.sba_dual.sub_less_eq_def)

lemma pSum_below_nat:
  "nat_test t s  (m<k . t m * -p  -q)  pSum t k * -p  -q"
  by (simp add: nat_test_seq pSum_below)

lemma pSum_below_sum:
  "nat_test t s  pSum t x  s"
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_unit nat_test_def one_def pSum_below_nat pSum_test_nat)

lemma ascending_chain_sup_left:
  "ascending_chain t  test_seq t  ascending_chain (λn . -p  t n)  test_seq (λn . -p  t n)"
  by (smt (z3) ord.ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma ascending_chain_sup_right:
  "ascending_chain t  test_seq t  ascending_chain (λn . t n  -p)  test_seq (λn . t n  -p)"
  by (smt ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma ascending_chain_mult_left:
  "ascending_chain t  test_seq t  ascending_chain (λn . -p * t n)  test_seq (λn . -p * t n)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma ascending_chain_mult_right:
  "ascending_chain t  test_seq t  ascending_chain (λn . t n * -p)  test_seq (λn . t n * -p)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_sup_left:
  "descending_chain t  test_seq t  descending_chain (λn . -p  t n)  test_seq (λn . -p  t n)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma descending_chain_sup_right:
  "descending_chain t  test_seq t  descending_chain (λn . t n  -p)  test_seq (λn . t n  -p)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma descending_chain_mult_left:
  "descending_chain t  test_seq t  descending_chain (λn . -p * t n)  test_seq (λn . -p * t n)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_mult_right:
  "descending_chain t  test_seq t  descending_chain (λn . t n * -p)  test_seq (λn . t n * -p)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

end

end

Theory Test_Iterings

(* Title:      Test Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Test Iterings›

theory Test_Iterings

imports Stone_Kleene_Relation_Algebras.Iterings Tests

begin

class test_itering = itering + tests + while +
  assumes while_def: "p  y = (p * y) * -p"
begin

lemma wnf_lemma_5:
  "(-p  -q) * (-q * x  --q * y) = -q * x  --q * -p * y"
  by (smt (z3) mult_left_dist_sup sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_idempotent tests_dual.sup_idempotent mult_assoc tests_dual.wnf_lemma_3)

lemma test_case_split_left_equal:
  "-z * x = -z * y  --z * x = --z * y  x = y"
  by (metis case_split_left_equal tests_dual.inf_complement)

lemma preserves_equation:
  "-y * x  x * -y  -y * x = -y * x * -y"
  apply (rule iffI)
  apply (simp add: test_preserves_equation tests_dual.sub_bot_least)
  by (simp add: test_preserves_equation tests_dual.sub_bot_least)

text ‹Theorem 5›

lemma preserve_test:
  "-y * x  x * -y  -y * x = -y * x * -y"
  using circ_simulate preserves_equation by blast

text ‹Theorem 5›

lemma import_test:
  "-y * x  x * -y  -y * x = -y * (-y * x)"
  by (simp add: circ_import tests_dual.sub_bot_least)

definition ite :: "'a  'a  'a  'a" ("_  _  _" [58,58,58] 57)
  where "x  p  y  p * x  -p * y"

definition it :: "'a  'a  'a" ("_  _" [58,58] 57)
  where "p  x  p * x  -p"

(*
definition while :: "'a ⇒ 'a ⇒ 'a" (infixr "⋆" 59)
  where "p ⋆ y ≡ (p * y) * -p"
*)

definition assigns :: "'a  'a  'a  bool"
  where "assigns x p q  x = x * (p * q  -p * -q)"

definition preserves :: "'a  'a  bool"
  where "preserves x p  p * x  x * p  -p * x  x * -p"

lemma ite_neg:
  "x  -p  y = y  --p  x"
  by (simp add: ite_def sup_commute)

lemma ite_import_true:
  "x  -p  y = -p * x  -p  y"
  by (metis ite_def tests_dual.sup_idempotent mult_assoc)

lemma ite_import_false:
  "x  -p  y = x  -p  --p * y"
  by (metis ite_import_true ite_neg)

lemma ite_import_true_false:
  "x  -p  y = -p * x  -p  --p * y"
  using ite_import_false ite_import_true by auto

lemma ite_context_true:
  "-p * (x  -p  y) = -p * x"
  by (metis sup_monoid.add_0_left tests_dual.sup_right_zero tests_dual.top_double_complement wnf_lemma_5 sup_bot_right ite_def mult_assoc mult_left_zero)

lemma ite_context_false:
  "--p * (x  -p  y) = --p * y"
  by (metis ite_neg ite_context_true)

lemma ite_context_import:
  "-p * (x  -q  y) = -p * (x  -p * -q  y)"
  by (smt ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup)

lemma ite_conjunction:
  "(x  -q  y)  -p  y = x  -p * -q  y"
  by (smt sup_assoc sup_commute ite_def mult_assoc tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_complement_intro)

lemma ite_disjunction:
  "x  -p  (x  -q  y) = x  -p  -q  y"
  by (smt (z3) tests_dual.sba_dual.sub_sup_closed sup_assoc ite_def mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan mult_left_dist_sup mult_right_dist_sup tests_dual.inf_demorgan)

lemma wnf_lemma_6:
  "(-p  -q) * (x  --p * -q  y) = (-p  -q) * (y  -p  x)"
  by (smt (z3) ite_conjunction ite_context_false ite_context_true semiring.distrib_right tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.sub_inf_def tests_dual.sba_dual.sup_complement_intro tests_dual.sub_complement)

lemma it_ite:
  "-p  x = x  -p  1"
  by (simp add: it_def ite_def)

lemma it_neg:
  "--p  x = 1  -p  x"
  using it_ite ite_neg by auto

lemma it_import_true:
  "-p  x = -p  -p * x"
  using it_ite ite_import_true by auto

lemma it_context_true:
  "-p * (-p  x) = -p * x"
  by (simp add: it_ite ite_context_true)

lemma it_context_false:
  "--p * (-p  x) = --p"
  using it_ite ite_context_false by force

lemma while_unfold_it:
  "-p  x = -p  x * (-p  x)"
  by (metis circ_loop_fixpoint it_def mult_assoc while_def)

lemma while_context_false:
  "--p * (-p  x) = --p"
  by (metis it_context_false while_unfold_it)

lemma while_context_true:
  "-p * (-p  x) = -p * x * (-p  x)"
  by (metis it_context_true mult_assoc while_unfold_it)

lemma while_zero:
  "bot  x = 1"
  by (metis circ_zero mult_left_one mult_left_zero one_def while_def)

lemma wnf_lemma_7:
  "1 * (bot  1) = 1"
  by (simp add: while_zero)

lemma while_import_condition:
  "-p  x = -p  -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent while_def)

lemma while_import_condition_2:
  "-p * -q  x = -p * -q  -p * x"
  by (metis mult_assoc tests_dual.sup_idempotent sub_comm while_def)

lemma wnf_lemma_8:
  "-r * (-p  --p * -q)  (x  --p * -q  y) = -r * (-p  -q)  (y  -p  x)"
  by (metis mult_assoc while_def wnf_lemma_6 tests_dual.sba_dual.sup_complement_intro)

text ‹Theorem 6 - see Theorem 31 on page 329 of Back and von Wright, Acta Informatica 36:295-334, 1999›

lemma split_merge_loops:
  assumes "--p * y  y * --p"
    shows "(-p  -q)  (x  -p  y) = (-p  x) * (-q  y)"
proof -
  have "-p  -q  (x  -p  y) = (-p * x  --p * -q * y) * --p * --q"
    by (smt ite_def mult_assoc sup_commute tests_dual.inf_demorgan while_def wnf_lemma_5)
  thus ?thesis
    by (smt assms circ_sup_1 circ_slide import_test mult_assoc preserves_equation sub_comm while_context_false while_def)
qed

lemma assigns_same:
  "assigns x (-p) (-p)"
  by (simp add: assigns_def)

lemma preserves_equation_test:
  "preserves x (-p)  -p * x = -p * x * -p  --p * x = --p * x * --p"
  using preserves_def preserves_equation by auto

lemma preserves_test:
  "preserves (-q) (-p)"
  using tests_dual.sub_commutative preserves_def by auto

lemma preserves_zero:
  "preserves bot (-p)"
  using tests_dual.sba_dual.sub_bot_def preserves_test by blast

lemma preserves_one:
  "preserves 1 (-p)"
  using preserves_def by force

lemma preserves_sup:
  "preserves x (-p)  preserves y (-p)  preserves (x  y) (-p)"
  by (simp add: mult_left_dist_sup mult_right_dist_sup preserves_equation_test)

lemma preserves_mult:
  "preserves x (-p)  preserves y (-p)  preserves (x * y) (-p)"
  by (smt (verit, best) mult_assoc preserves_equation_test)

lemma preserves_ite:
  "preserves x (-p)  preserves y (-p)  preserves (x  -q  y) (-p)"
  by (simp add: ite_def preserves_mult preserves_sup preserves_test)

lemma preserves_it:
  "preserves x (-p)  preserves (-q  x) (-p)"
  by (simp add: it_ite preserves_ite preserves_one)

lemma preserves_circ:
  "preserves x (-p)  preserves (x) (-p)"
  by (meson circ_simulate preserves_def)

lemma preserves_while:
  "preserves x (-p)  preserves (-q  x) (-p)"
  using while_def preserves_circ preserves_mult preserves_test by auto

lemma preserves_test_neg:
  "preserves x (-p)  preserves x (--p)"
  using preserves_def by auto

lemma preserves_import_circ:
  "preserves x (-p)  -p * x = -p * (-p * x)"
  using import_test preserves_def by blast

lemma preserves_simulate:
  "preserves x (-p)  -p * x = -p * x * -p"
  using preserve_test preserves_def by auto

lemma preserves_import_ite:
  assumes "preserves z (-p)"
    shows "z * (x  -p  y) = z * x  -p  z * y"
proof -
  have 1: "-p * z * (x  -p  y) = -p * (z * x  -p  z * y)"
    by (smt assms ite_context_true mult_assoc preserves_equation_test)
  have "--p * z * (x  -p  y) = --p * (z * x  -p  z * y)"
    by (smt (z3) assms ite_context_false mult_assoc preserves_equation_test)
  thus ?thesis
    using 1 by (metis mult_assoc test_case_split_left_equal)
qed

lemma preserves_while_context:
  "preserves x (-p)  -p * (-q  x) = -p * (-p * -q  x)"
  by (smt (verit, del_insts) mult_assoc tests_dual.sup_complement_intro tests_dual.sub_sup_demorgan preserves_import_circ preserves_mult preserves_simulate preserves_test while_def)

lemma while_ite_context_false:
  assumes "preserves y (-p)"
    shows "--p * (-p  -q  (x  -p  y)) = --p * (-q  y)"
proof -
  have "--p * (-p  -q  (x  -p  y)) = --p * (--p * -q * y) * -(-p  -q)"
    by (smt (z3) assms import_test mult_assoc preserves_equation preserves_equation_test sub_comm while_def tests_dual.sba_dual.sub_sup_demorgan preserves_test split_merge_loops while_context_false)
  thus ?thesis
    by (metis (no_types, lifting) assms preserves_def mult.assoc split_merge_loops while_context_false)
qed

text ‹Theorem 7.1›

lemma while_ite_norm:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y1 (-q)"
      and "preserves y2 (-q)"
    shows "z * (x1 * (-r1  y1)  -p  x2 * (-r2  y2)) = z * (x1  -q  x2) * ((-q * -r1  --q * -r2)  (y1  -q  y2))"
proof -
  have 1: "-(-q * -r1  --q * -r2) = -q * --r1  --q * --r2"
    by (smt (z3) tests_dual.complement_2 tests_dual.sub_sup_closed tests_dual.case_duality tests_dual.sub_sup_demorgan)
  have "-p * -q * x1 * (-q * -r1 * y1  --q * -r2 * y2) * (-q * --r1  --q * --r2) = -p * -q * x1 * -q * (-q * (-q * -r1 * y1  --q * -r2 * y2)) * (-q * --r1  --q * --r2)"
    by (smt (verit, del_insts) assms(2,4,5) mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test)
  also have "... = -p * -q * x1 * -q * (-q * -r1 * y1) * (-q * --r1  --q * --r2)"
    using ite_context_true ite_def mult_assoc by auto
  finally have 2: "-p * -q * x1 * (-q * -r1 * y1  --q * -r2 * y2) * (-q * --r1  --q * --r2) = -p * -q * x1 * (-r1 * y1) * --r1"
    by (smt (verit, del_insts) assms ite_context_true ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test)
  have "--p * --q * x2 * (-q * -r1 * y1  --q * -r2 * y2) * (-q * --r1  --q * --r2) = --p * --q * x2 * --q * (--q * (-q * -r1 * y1  --q * -r2 * y2)) * (-q * --r1  --q * --r2)"
    by (smt (verit, del_insts) assms mult_assoc preserves_sup preserves_equation_test preserves_import_circ preserves_mult preserves_test preserves_test_neg)
  also have "... = --p * --q * x2 * --q * (--q * -r2 * y2) * (-q * --r1  --q * --r2)"
    using ite_context_false ite_def mult_assoc by auto
  finally have "--p * --q * x2 * (-q * -r1 * y1  --q * -r2 * y2) * (-q * --r1  --q * --r2) = --p * --q * x2 * (-r2 * y2) * --r2"
    by (smt (verit, del_insts) assms(3,5) ite_context_false ite_def mult_assoc preserves_equation_test preserves_import_circ preserves_mult preserves_simulate preserves_test preserves_test_neg)
  thus ?thesis
    using 1 2 by (smt (z3) assms(1) assigns_def mult_assoc mult_right_dist_sup while_def ite_context_false ite_context_true tests_dual.sub_commutative)
qed

lemma while_it_norm:
  "assigns z (-p) (-q)  preserves x (-q)  preserves y (-q)  z * (-p  x * (-r  y)) = z * (-q  x) * (-q * -r  y)"
  by (metis sup_bot_right tests_dual.sup_right_zero it_context_true it_ite tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_else_norm:
  "assigns z (-p) (-q)  preserves x (-q)  preserves y (-q)  z * (1  -p  x * (-r  y)) = z * (1  -q  x) * (--q * -r  y)"
  by (metis sup_bot_left tests_dual.sup_right_zero ite_context_false tests_dual.complement_bot preserves_one while_import_condition_2 while_ite_norm wnf_lemma_7)

lemma while_while_pre_norm:
  "-p  x * (-q  y) = -p  x * (-p  -q  (y  -q  x))"
  by (smt sup_commute circ_sup_1 circ_left_unfold circ_slide it_def ite_def mult_assoc mult_left_one mult_right_dist_sup tests_dual.inf_demorgan while_def wnf_lemma_5)

text ‹Theorem 7.2›

lemma while_while_norm:
  "assigns z (-p) (-r)  preserves x (-r)  preserves y (-r)  z * (-p  x * (-q  y)) = z * (-r  x) * (-r * (-p  -q)  (y  -q  x))"
  by (smt tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite while_it_norm while_while_pre_norm)

lemma while_seq_replace:
  "assigns z (-p) (-q)  z * (-p  x * z) * y = z * (-q  x * z) * y"
  by (smt assigns_def circ_slide mult_assoc tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_2 tests_dual.wnf_lemma_3 tests_dual.wnf_lemma_4 while_def)

lemma while_ite_replace:
  "assigns z (-p) (-q)  z * (x  -p  y) = z * (x  -q  y)"
  by (smt assigns_def ite_def mult_assoc mult_left_dist_sup sub_comm tests_dual.wnf_lemma_1 tests_dual.wnf_lemma_3)

lemma while_post_norm_an:
  assumes "preserves y (-p)"
    shows "(-p  x) * y = y  --p  (-p  x * (--p  y))"
proof -
  have "-p * (-p * x * (--p * y  -p)) * --p = -p * x * ((--p * y  -p) * -p * x) * (--p * y  -p) * --p"
    by (metis circ_slide_1 while_def mult_assoc while_context_true)
  also have "... = -p * x * (--p * y * bot  -p * x) * --p * y"
    by (smt assms sup_bot_right mult_assoc tests_dual.sup_complement tests_dual.sup_idempotent mult_left_zero mult_right_dist_sup preserves_equation_test sub_comm)
  finally have "-p * (-p * x * (--p * y  -p)) * --p = -p * x * (-p * x) * --p * y"
    by (metis circ_sup_mult_zero sup_commute mult_assoc)
  thus ?thesis
    by (smt circ_left_unfold tests_dual.double_negation it_def ite_def mult_assoc mult_left_one mult_right_dist_sup while_def)
qed

lemma while_post_norm:
  "preserves y (-p)  (-p  x) * y = -p  x * (1  -p  y)  -p  y"
  using it_neg ite_neg while_post_norm_an by force

lemma wnf_lemma_9:
  assumes "assigns z (-p) (-q)"
      and "preserves x1 (-q)"
      and "preserves y1 (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves x2 (-p)"
      and "preserves y2 (-p)"
    shows "z * (x1  -q  x2) * (-q * -p  -r  (y1  -q * -p  y2)) = z * (x1  -p  x2) * (-p  -r  (y1  -p  y2))"
proof -
  have "z * --p * --q * (x1  -q  x2) * (-q * -p  -r  (y1  -q * -p  y2)) = z * --p * --q * x2 * --q * (--q * (-q * -p  -r)  (y1  -q * -p  y2))"
    by (smt (verit, del_insts) assms(3-5) tests_dual.double_negation ite_context_false mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context)
  also have "... = z * --p * --q * x2 * --q * (--q * -r  --q * y2)"
    by (smt sup_bot_left tests_dual.double_negation ite_conjunction ite_context_false mult_assoc tests_dual.sup_complement mult_left_dist_sup mult_left_zero while_import_condition_2)
  also have "... = z * --p * --q * x2 * (-r  y2)"
    by (metis assms(4,5) mult_assoc preserves_equation_test preserves_test_neg preserves_while_context while_import_condition_2)
  finally have 1: "z * --p * --q * (x1  -q  x2) * (-q * -p  -r  (y1  -q * -p  y2)) = z * --p * --q * (x1  -q  x2) * (-p  -r  (y1  -p  y2))"
    by (smt assms(6,7) ite_context_false mult_assoc preserves_equation_test sub_comm while_ite_context_false)
  have "z * -p * -q * (x1  -q  x2) * (-q * -p  -r  (y1  -q * -p  y2)) = z * -p * -q * (x1  -q  x2) * -q * (-q * (-p  -r)  -q * (y1  -p  y2))"
    by (smt (verit, del_insts) assms(2-5) tests_dual.double_negation ite_context_import mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent mult_left_dist_sup tests_dual.inf_demorgan preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  hence "z * -p * -q * (x1  -q  x2) * (-q * -p  -r  (y1  -q * -p  y2)) = z * -p * -q * (x1  -q  x2) * (-p  -r  (y1  -p  y2))"
    by (smt assms(2-5) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_while_context while_import_condition_2)
  thus ?thesis
    using 1 by (smt assms(1) assigns_def mult_assoc mult_left_dist_sup mult_right_dist_sup while_ite_replace)
qed

text ‹Theorem 7.3›

lemma while_seq_norm:
  assumes "assigns z1 (-r1) (-q)"
      and "preserves x2 (-q)"
      and "preserves y2 (-q)"
      and "preserves z2 (-q)"
      and "z1 * z2 = z2 * z1"
      and "assigns z2 (-q) (-r)"
      and "preserves y1 (-r)"
      and "preserves z1 (-r)"
      and "preserves x2 (-r)"
      and "preserves y2 (-r)"
    shows "x1 * z1 * z2 * (-r1  y1 * z1) * x2 * (-r2  y2) = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2)  -q  x2) * (-q  -r2  (y1 * z1 * (1  -q  x2)  -q  y2))"
proof -
  have 1: "preserves (y1 * z1 * (1  -q  x2)) (-r)"
    by (simp add: assms(7-9) ite_def preserves_mult preserves_sup preserves_test)
  hence 2: "preserves (y1 * z1 * (1  -q  x2)  -q  y2) (-r)"
    by (simp add: assms(10) preserves_ite)
  have "x1 * z1 * z2 * (-r1  y1 * z1) * x2 * (-r2  y2) = x1 * z1 * z2 * (-q  y1 * z1) * x2 * (-r2  y2)"
    using assms(1,5) mult_assoc while_seq_replace by auto
  also have "... = x1 * z1 * z2 * (-q  y1 * z1 * (1  -q  x2 * (-r2  y2))  -q  x2 * (-r2  y2))"
    by (smt assms(2,3) mult_assoc preserves_mult preserves_while while_post_norm)
  also have "... = x1 * z1 * (z2 * (-q  y1 * z1 * (1  -q  x2) * (--q * -r2  y2))  -q  z2 * x2 * (-r2  y2))"
    by (smt assms(2-4) assigns_same mult_assoc preserves_import_ite while_else_norm)
  also have "... = x1 * z1 * (z2 * (-r  y1 * z1 * (1  -q  x2)) * (-r * (-q  -r2)  (y1 * z1 * (1  -q  x2)  -q  y2))  -q  z2 * x2 * (-r2  y2))"
    by (smt assms(6-10) tests_dual.double_negation tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_while_norm wnf_lemma_8)
  also have "... = x1 * z1 * z2 * ((-r  y1 * z1 * (1  -q  x2)) * (-r * (-q  -r2)  (y1 * z1 * (1  -q  x2)  -q  y2))  -r  x2 * (-r2  y2))"
    by (smt assms(4,6) mult_assoc preserves_import_ite while_ite_replace)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1  -q  x2)) * (-r * (-q  -r2)  (y1 * z1 * (1  -q  x2)  -q  y2))  -r  x2 * (-r2  y2))"
    by (smt mult_assoc it_context_true ite_import_true)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1  -q  x2)) * -r * (-r * (-q  -r2)  (y1 * z1 * (1  -q  x2)  -q  y2))  -r  x2 * (-r2  y2))"
    using 1 by (simp add: preserves_equation_test)
  also have "... = x1 * z1 * z2 * (-r * (y1 * z1 * (1  -q  x2)) * -r * (-q  -r2  (y1 * z1 * (1  -q  x2)  -q  y2))  -r  x2 * (-r2  y2))"
    using 2 by (smt (z3) tests_dual.sba_dual.sub_sup_closed mult_assoc preserves_while_context)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2) * (-q  -r2  (y1 * z1 * (1  -q  x2)  -q  y2))  -q  x2 * (-r2  y2))"
    by (smt assms(6-9) tests_dual.double_negation ite_import_true mult_assoc tests_dual.sup_idempotent preserves_equation_test preserves_ite preserves_one while_ite_replace)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2)  -r  x2) * ((-r * (-q  -r2)  --r * -r2)  ((y1 * z1 * (1  -q  x2)  -q  y2)  -r  y2))"
    by (smt assms(6-10) tests_dual.double_negation mult_assoc tests_dual.sub_sup_demorgan tests_dual.inf_demorgan preserves_ite preserves_mult preserves_one while_ite_norm)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2)  -r  x2) * ((-r * (-q  -r2)  --r * -r2)  (y1 * z1 * (1  -q  x2)  -r * -q  y2))"
    using ite_conjunction by simp
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2)  -r  x2) * ((-r * -q  -r2)  (y1 * z1 * (1  -q  x2)  -r * -q  y2))"
    by (smt (z3) mult_left_dist_sup sup_assoc tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)
  also have "... = x1 * z1 * z2 * (y1 * z1 * (1  -q  x2)  -q  x2) * (-q  -r2  (y1 * z1 * (1  -q  x2)  -q  y2))"
    using 1 by (metis assms(2,3,6,9,10) mult_assoc wnf_lemma_9)
  finally show ?thesis
    .
qed

end

end

Theory N_Semirings

(* Title:      N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Semirings›

theory N_Semirings

imports Test_Iterings Omega_Algebras

begin

class n_semiring = bounded_idempotent_left_zero_semiring + n + L +
  assumes n_bot         : "n(bot) = bot"
  assumes n_top         : "n(top) = 1"
  assumes n_dist_sup    : "n(x  y) = n(x)  n(y)"
  assumes n_export      : "n(n(x) * y) = n(x) * n(y)"
  assumes n_sub_mult_bot: "n(x) = n(x * bot) * n(x)"
  assumes n_L_split     : "x * n(y) * L = x * bot  n(x * y) * L"
  assumes n_split       : "x  x * bot  n(x * L) * top"
begin

lemma n_sub_one:
  "n(x)  1"
  by (metis sup_left_top sup_ge2 n_dist_sup n_top)

text ‹Theorem 15›

lemma n_isotone:
  "x  y  n(x)  n(y)"
  by (metis le_iff_sup n_dist_sup)

lemma n_mult_idempotent:
  "n(x) * n(x) = n(x)"
  by (metis mult_assoc mult_1_right n_export n_sub_mult_bot n_top)

text ‹Theorem 15.3›

lemma n_mult_bot:
  "n(x) = n(x * bot)"
  by (metis sup_commute sup_left_top sup_bot_right mult_left_dist_sup mult_1_right n_dist_sup n_sub_mult_bot n_top)

lemma n_mult_left_upper_bound:
  "n(x)  n(x * y)"
  by (metis mult_right_isotone n_isotone n_mult_bot bot_least)

lemma n_mult_right_bot:
  "n(x) * bot = bot"
  by (metis sup_left_top sup_bot_left mult_left_one mult_1_right n_export n_dist_sup n_sub_mult_bot n_top n_bot)

text ‹Theorem 15.9›

lemma n_mult_n:
  "n(x * n(y)) = n(x)"
  by (metis mult_assoc n_mult_right_bot n_mult_bot)

lemma n_mult_left_absorb_sup:
  "n(x) * (n(x)  n(y)) = n(x)"
  by (metis sup_left_top mult_left_dist_sup mult_1_right n_dist_sup n_mult_idempotent n_top)

lemma n_mult_right_absorb_sup:
  "(n(x)  n(y)) * n(y) = n(y)"
  by (metis sup_commute sup_left_top mult_left_one mult_right_dist_sup n_dist_sup n_mult_idempotent n_top)

lemma n_sup_left_absorb_mult:
  "n(x)  n(x) * n(y) = n(x)"
  using mult_left_dist_sup n_mult_idempotent n_mult_left_absorb_sup by auto

lemma n_sup_right_absorb_mult:
  "n(x) * n(y)  n(y) = n(y)"
  using mult_right_dist_sup n_mult_idempotent n_mult_right_absorb_sup by auto

lemma n_mult_commutative:
  "n(x) * n(y) = n(y) * n(x)"
  by (smt sup_commute mult_left_dist_sup mult_right_dist_sup n_sup_left_absorb_mult n_sup_right_absorb_mult n_export n_mult_idempotent)

lemma n_sup_left_dist_mult:
  "n(x)  n(y) * n(z) = (n(x)  n(y)) * (n(x)  n(z))"
  by (metis sup_assoc mult_left_dist_sup mult_right_dist_sup n_sup_right_absorb_mult n_mult_commutative n_mult_left_absorb_sup)

lemma n_sup_right_dist_mult:
  "n(x) * n(y)  n(z) = (n(x)  n(z)) * (n(y)  n(z))"
  by (simp add: sup_commute n_sup_left_dist_mult)

lemma n_order:
  "n(x)  n(y)  n(x) * n(y) = n(x)"
  by (metis le_iff_sup n_sup_right_absorb_mult n_mult_left_absorb_sup)

lemma n_mult_left_lower_bound:
  "n(x) * n(y)  n(x)"
  by (simp add: sup.orderI n_sup_left_absorb_mult)

lemma n_mult_right_lower_bound:
  "n(x) * n(y)  n(y)"
  by (simp add: le_iff_sup n_sup_right_absorb_mult)

lemma n_mult_least_upper_bound:
  "n(x)  n(y)  n(x)  n(z)  n(x)  n(y) * n(z)"
  by (metis order.trans mult_left_isotone n_mult_commutative n_mult_right_lower_bound n_order)

lemma n_mult_left_divisibility:
  "n(x)  n(y)  (z . n(x) = n(y) * n(z))"
  by (metis n_mult_commutative n_mult_left_lower_bound n_order)

lemma n_mult_right_divisibility:
  "n(x)  n(y)  (z . n(x) = n(z) * n(y))"
  by (simp add: n_mult_commutative n_mult_left_divisibility)

text ‹Theorem 15.1›

lemma n_one:
  "n(1) = bot"
  by (metis mult_left_one n_mult_bot n_bot)

lemma n_split_equal:
  "x  n(x * L) * top = x * bot  n(x * L) * top"
  using n_split order_trans sup.cobounded1 sup_same_context zero_right_mult_decreasing by blast

lemma n_split_top:
  "x * top  x * bot  n(x * L) * top"
  by (metis mult_left_isotone n_split vector_bot_closed vector_mult_closed vector_sup_closed vector_top_closed)

text ‹Theorem 15.2›

lemma n_L:
  "n(L) = 1"
  by (metis sup_bot_left order.antisym mult_left_one n_export n_isotone n_mult_commutative n_split_top n_sub_one n_top)

text ‹Theorem 15.5›

lemma n_split_L:
  "x * L = x * bot  n(x * L) * L"
  by (metis mult_1_right n_L n_L_split)

lemma n_n_L:
  "n(n(x) * L) = n(x)"
  by (simp add: n_export n_L)

lemma n_L_decreasing:
  "n(x) * L  x"
  by (metis mult_left_zero n_L_split order_trans sup.orderI zero_right_mult_decreasing mult_assoc n_mult_bot)

text ‹Theorem 15.10›

lemma n_galois:
  "n(x)  n(y)  n(x) * L  y"
  by (metis order.trans mult_left_isotone n_L_decreasing n_isotone n_n_L)

text ‹Theorem 15.6›

lemma split_L:
  "x * L  x * bot  L"
  by (metis sup_commute sup_left_isotone n_galois n_L n_split_L n_sub_one)

text ‹Theorem 15.7›

lemma L_left_zero:
  "L * x = L"
  by (metis order.antisym mult.left_neutral mult_left_zero zero_right_mult_decreasing n_L n_L_decreasing n_mult_bot mult.assoc)

text ‹Theorem 15.8›

lemma n_mult:
  "n(x * n(y) * L) = n(x * y)"
  using n_L_split n_dist_sup sup.absorb2 n_mult_left_upper_bound n_mult_bot n_n_L by auto

lemma n_mult_top:
  "n(x * n(y) * top) = n(x * y)"
  by (metis mult_1_right n_mult n_top)

text ‹Theorem 15.4›

lemma n_top_L:
  "n(x * top) = n(x * L)"
  by (metis mult_1_right n_L n_mult_top)

lemma n_top_split:
  "x * n(y) * top  x * bot  n(x * y) * top"
  by (metis mult_assoc n_mult n_mult_right_bot n_split_top)

lemma n_mult_right_upper_bound:
  "n(x * y)  n(z)  n(x)  n(z)  x * n(y) * L  x * bot  n(z) * L"
  apply (rule iffI)
  apply (metis sup_right_isotone order.eq_iff mult_isotone n_L_split n_mult_left_upper_bound order_trans)
  by (smt (verit, ccfv_threshold) n_dist_sup n_export sup.absorb_iff2 n_mult n_mult_commutative n_mult_bot n_n_L)

lemma n_preserves_equation:
  "n(y) * x  x * n(y)  n(y) * x = n(y) * x * n(y)"
  using eq_refl test_preserves_equation n_mult_idempotent n_sub_one by auto

definition ni :: "'a  'a"
  where "ni x = n(x) * L"

lemma ni_bot:
  "ni(bot) = bot"
  by (simp add: n_bot ni_def)

lemma ni_one:
  "ni(1) = bot"
  by (simp add: n_one ni_def)

lemma ni_L:
  "ni(L) = L"
  by (simp add: n_L ni_def)

lemma ni_top:
  "ni(top) = L"
  by (simp add: n_top ni_def)

lemma ni_dist_sup:
  "ni(x  y) = ni(x)  ni(y)"
  by (simp add: mult_right_dist_sup n_dist_sup ni_def)

lemma ni_mult_bot:
  "ni(x) = ni(x * bot)"
  using n_mult_bot ni_def by auto

lemma ni_split:
  "x * ni(y) = x * bot  ni(x * y)"
  using n_L_split mult_assoc ni_def by auto

lemma ni_decreasing:
  "ni(x)  x"
  by (simp add: n_L_decreasing ni_def)

lemma ni_isotone:
  "x  y  ni(x)  ni(y)"
  using mult_left_isotone n_isotone ni_def by auto

lemma ni_mult_left_upper_bound:
  "ni(x)  ni(x * y)"
  using mult_left_isotone n_mult_left_upper_bound ni_def by force

lemma ni_idempotent:
  "ni(ni(x)) = ni(x)"
  by (simp add: n_n_L ni_def)

lemma ni_below_L:
  "ni(x)  L"
  using n_L n_galois n_sub_one ni_def by auto

lemma ni_left_zero:
  "ni(x) * y = ni(x)"
  by (simp add: L_left_zero mult_assoc ni_def)

lemma ni_split_L:
  "x * L = x * bot  ni(x * L)"
  using n_split_L ni_def by auto

lemma ni_top_L:
  "ni(x * top) = ni(x * L)"
  by (simp add: n_top_L ni_def)

lemma ni_galois:
  "ni(x)  ni(y)  ni(x)  y"
  by (metis n_galois n_n_L ni_def)

lemma ni_mult:
  "ni(x * ni(y)) = ni(x * y)"
  using mult_assoc n_mult ni_def by auto

lemma ni_n_order:
  "ni(x)  ni(y)  n(x)  n(y)"
  using n_galois ni_def ni_galois by auto

lemma ni_n_equal:
  "ni(x) = ni(y)  n(x) = n(y)"
  by (metis n_n_L ni_def)

lemma ni_mult_right_upper_bound:
  "ni(x * y)  ni(z)  ni(x)  ni(z)  x * ni(y)  x * bot  ni(z)"
  using mult_assoc n_mult_right_upper_bound ni_def ni_n_order by auto

lemma n_ni:
  "n(ni(x)) = n(x)"
  by (simp add: n_n_L ni_def)

lemma ni_n:
  "ni(n(x)) = bot"
  by (metis n_mult_right_bot ni_mult_bot ni_bot)

lemma ni_n_galois:
  "n(x)  n(y)  ni(x)  y"
  by (simp add: n_galois ni_def)

lemma n_mult_ni:
  "n(x * ni(y)) = n(x * y)"
  using ni_mult ni_n_equal by auto

lemma ni_mult_n:
  "ni(x * n(y)) = ni(x)"
  by (simp add: n_mult_n ni_def)

lemma ni_export:
  "ni(n(x) * y) = n(x) * ni(y)"
  by (simp add: n_mult_right_bot ni_split)

lemma ni_mult_top:
  "ni(x * n(y) * top) = ni(x * y)"
  by (simp add: n_mult_top ni_def)

lemma ni_n_bot:
  "ni(x) = bot  n(x) = bot"
  using n_bot ni_n_equal ni_bot by force

lemma ni_n_L:
  "ni(x) = L  n(x) = 1"
  using n_L ni_L ni_n_equal by force

(* independence of axioms, checked in n_semiring without the respective axiom:
lemma n_bot         : "n(bot) = bot" nitpick [expect=genuine,card=2] oops
lemma n_top         : "n(top) = 1" nitpick [expect=genuine,card=3] oops
lemma n_dist_sup    : "n(x ⊔ y) = n(x) ⊔ n(y)" nitpick [expect=genuine,card=5] oops
lemma n_export      : "n(n(x) * y) = n(x) * n(y)" nitpick [expect=genuine,card=6] oops
lemma n_sub_mult_bot: "n(x) = n(x * bot) * n(x)" nitpick [expect=genuine,card=2] oops
lemma n_L_split     : "x * n(y) * L = x * bot ⊔ n(x * y) * L" nitpick [expect=genuine,card=4] oops
lemma n_split       : "x ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=3] oops
*)

end

typedef (overloaded) 'a nImage = "{ x::'a::n_semiring . (y::'a . x = n(y)) }"
  by auto

lemma simp_nImage[simp]:
  "y . Rep_nImage x = n(y)"
  using Rep_nImage by simp

setup_lifting type_definition_nImage

text ‹Theorem 15›

instantiation nImage :: (n_semiring) bounded_idempotent_semiring
begin

lift_definition sup_nImage :: "'a nImage  'a nImage  'a nImage" is sup
  by (metis n_dist_sup)

lift_definition times_nImage :: "'a nImage  'a nImage  'a nImage" is times
  by (metis n_export)

lift_definition bot_nImage :: "'a nImage" is bot
  by (metis n_bot)

lift_definition one_nImage :: "'a nImage" is 1
  using n_L by auto

lift_definition top_nImage :: "'a nImage" is 1
  using n_L by auto

lift_definition less_eq_nImage :: "'a nImage  'a nImage  bool" is less_eq .

lift_definition less_nImage :: "'a nImage  'a nImage  bool" is less .

instance
  apply intro_classes
  apply (simp add: less_eq_nImage.rep_eq less_le_not_le less_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq)
  using less_eq_nImage.rep_eq apply force
  apply (simp add: less_eq_nImage.rep_eq Rep_nImage_inject)
  apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq sup_nImage.rep_eq)
  apply (simp add: sup_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: bot_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (simp add: sup_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq mult_left_dist_sup)
  apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inverse mult_right_dist_sup)
  apply (smt (z3) times_nImage.rep_eq Rep_nImage_inverse bot_nImage.rep_eq mult_left_zero)
  using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
  apply (simp add: one_nImage.rep_eq times_nImage.rep_eq less_eq_nImage.rep_eq)
  apply (smt (verit, del_insts) sup_nImage.rep_eq Rep_nImage Rep_nImage_inject mem_Collect_eq n_sub_one sup.absorb2 top_nImage.rep_eq)
  apply (simp add: less_eq_nImage.rep_eq mult.assoc times_nImage.rep_eq)
  using Rep_nImage_inject mult.assoc times_nImage.rep_eq apply fastforce
  using Rep_nImage_inject one_nImage.rep_eq times_nImage.rep_eq apply fastforce
  apply (metis (mono_tags, lifting) sup_nImage.rep_eq times_nImage.rep_eq Rep_nImage_inject mult_left_dist_sup)
  by (smt (z3) Rep_nImage_inject bot_nImage.rep_eq n_mult_right_bot simp_nImage times_nImage.rep_eq)

end

text ‹Theorem 15›

instantiation nImage :: (n_semiring) bounded_distrib_lattice
begin

lift_definition inf_nImage :: "'a nImage  'a nImage  'a nImage" is times
  by (metis n_export)

instance
  apply intro_classes
  apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_left_lower_bound simp_nImage)
  apply (metis (mono_tags) inf_nImage.rep_eq less_eq_nImage.rep_eq n_mult_right_lower_bound simp_nImage)
  apply (smt (z3) inf_nImage_def le_iff_sup less_eq_nImage.rep_eq mult_right_dist_sup n_mult_left_absorb_sup simp_nImage times_nImage.rep_eq times_nImage_def)
  apply simp
  by (smt (z3) Rep_nImage_inject inf_nImage.rep_eq n_sup_right_dist_mult simp_nImage sup.commute sup_nImage.rep_eq)

end

class n_itering = bounded_itering + n_semiring
begin

lemma mult_L_circ:
  "(x * L) = 1  x * L"
  by (metis L_left_zero circ_mult mult_assoc)

lemma mult_L_circ_mult:
  "(x * L) * y = y  x * L"
  by (metis L_left_zero mult_L_circ mult_assoc mult_left_one mult_right_dist_sup)

lemma circ_L:
  "L = L  1"
  by (metis L_left_zero sup_commute circ_left_unfold)

lemma circ_n_L:
  "x * n(x) * L = x * bot"
  by (metis sup_bot_left circ_left_unfold circ_plus_same mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split)

lemma n_circ_left_unfold:
  "n(x) = n(x * x)"
  by (metis circ_n_L circ_plus_same n_mult n_mult_bot)

lemma ni_circ:
  "ni(x) = 1  ni(x)"
  by (simp add: mult_L_circ ni_def)

lemma circ_ni:
  "x * ni(x) = x * bot"
  using circ_n_L ni_def mult_assoc by auto

lemma ni_circ_left_unfold:
  "ni(x) = ni(x * x)"
  by (simp add: ni_def n_circ_left_unfold)

lemma n_circ_import:
  "n(y) * x  x * n(y)  n(y) * x = n(y) * (n(y) * x)"
  by (simp add: circ_import n_mult_idempotent n_sub_one)

end

class n_omega_itering = left_omega_conway_semiring + n_itering +
  assumes circ_circ: "x = L  x"
begin

lemma L_below_one_circ:
  "L  1"
  by (metis sup_left_divisibility circ_circ circ_one)

lemma circ_below_L_sup_star:
  "x  L  x"
  by (metis circ_circ circ_increasing)

lemma L_sup_circ_sup_star:
  "L  x = L  x"
  by (metis circ_circ circ_star star_circ)

lemma circ_one_L:
  "1 = L  1"
  using circ_circ circ_one star_one by auto

lemma one_circ_zero:
  "L = 1 * bot"
  by (metis L_left_zero circ_L circ_ni circ_one_L circ_plus_same ni_L)

lemma circ_not_simulate:
  "(x y z . x * z  z * y  x * z  z * y)  1 = bot"
  by (metis L_left_zero circ_one_L order.eq_iff mult_left_one mult_left_zero mult_right_sub_dist_sup_left n_L n_bot bot_least)

lemma star_circ_L:
  "x = L  x"
  by (simp add: circ_circ star_circ)

lemma circ_circ_2:
  "x = L  x"
  by (simp add: L_sup_circ_sup_star circ_circ)

lemma circ_sup_6:
  "L  (x  y) = (x * y)"
  by (metis circ_circ_2 sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_decompose_4)

lemma circ_sup_7:
  "(x * y) = L  (x  y)"
  using L_sup_circ_sup_star circ_sup_6 by auto

end

class n_omega_algebra_2 = bounded_left_zero_omega_algebra + n_semiring + Omega +
  assumes Omega_def: "xΩ = n(xω) * L  x"
begin

lemma mult_L_star:
  "(x * L) = 1  x * L"
  by (simp add: L_left_zero transitive_star mult_assoc)

lemma mult_L_omega:
  "(x * L)ω = x * L"
  by (metis L_left_zero omega_slide)

lemma mult_L_sup_star:
  "(x * L  y) = y  y * x * L"
  by (metis L_left_zero star.mult_zero_sup_circ_2 sup_commute mult_assoc)

lemma mult_L_sup_omega:
  "(x * L  y)ω = yω  y * x * L"
  by (metis L_left_zero mult_bot_add_omega sup_commute mult_assoc)

lemma mult_L_sup_circ:
  "(x * L  y)Ω = n(yω) * L  y  y * x * L"
  by (smt sup_assoc sup_commute Omega_def le_iff_sup mult_L_sup_omega mult_L_sup_star mult_right_dist_sup n_L_decreasing n_dist_sup)

lemma circ_sup_n:
  "(xΩ * y)Ω * xΩ = n((x * y)ω) * L  ((x * y) * x  (x * y) * n(xω) * L)"
  by (smt L_left_zero sup_assoc sup_commute Omega_def mult_L_sup_circ mult_assoc mult_left_dist_sup mult_right_dist_sup)

text ‹Theorem 20.6›

lemma n_omega_induct:
  "n(y)  n(x * y  z)  n(y)  n(xω  x * z)"
  by (smt sup_commute mult_assoc n_dist_sup n_galois n_mult omega_induct)

lemma n_Omega_left_unfold:
  "1  x * xΩ = xΩ"
proof -
  have "1  x * xΩ = 1  x * n(xω) * L  x * x"
    by (simp add: Omega_def semiring.distrib_left sup_assoc mult_assoc)
  also have "... = n(x * xω) * L  (1  x * x)"
    by (metis sup_assoc sup_commute sup_bot_left mult_left_dist_sup n_L_split)
  also have "... = n(xω) * L  x"
    using omega_unfold star_left_unfold_equal by auto
  also have "... = xΩ"
    by (simp add: Omega_def)
  finally show ?thesis
    .
qed

lemma n_Omega_circ_sup:
  "(x  y)Ω = (xΩ * y)Ω * xΩ"
proof -
  have "(xΩ * y)Ω * xΩ = n((x * y)ω) * L  ((x * y) * x  (x * y) * n(xω) * L)"
    by (simp add: circ_sup_n)
  also have "... = n((x * y)ω) * L  n((x * y) * xω) * L  (x * y) * bot  (x * y) * x"
    using n_L_split sup.left_commute sup_commute by auto
  also have "... = n((x * y)ω  (x * y) * xω) * L  (x * y) * x"
    by (smt sup_assoc sup_bot_left mult_left_dist_sup mult_right_dist_sup n_dist_sup)
  also have "... = (x  y)Ω"
    by (simp add: Omega_def omega_decompose star.circ_sup_9)
  finally show ?thesis
    ..
qed

lemma n_Omega_circ_simulate_right_sup:
  assumes "z * x  y * yΩ * z  w"
    shows "z * xΩ  yΩ * (z  w * xΩ)"
proof -
  have "z * x  y * yΩ * z  w"
    by (simp add: assms)
  also have "... = y * n(yω) * L  y * y * z  w"
    using L_left_zero Omega_def mult_right_dist_sup semiring.distrib_left mult_assoc by auto
  finally have 1: "z * x  n(yω) * L  y * y * z  w"
    by (metis sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_L_split omega_unfold)
  hence "(n(yω) * L  y * z  y * w * n(xω) * L  y * w * x) * x  n(yω) * L  y * (n(yω) * L  y * y * z  w)  y * w * n(xω) * L  y * w * x"
    by (smt L_left_zero sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... = n(yω) * L  y * n(yω) * L  y * y * y * z  y * w  y * w * n(xω) * L  y * w * x"
    using semiring.distrib_left sup_assoc mult_assoc by auto
  also have "... = n(yω) * L  y * n(yω) * L  y * y * y * z  y * w * n(xω) * L  y * w * x"
    by (smt (verit, ccfv_SIG) le_supI1 order.refl semiring.add_mono star.circ_back_loop_prefixpoint sup.bounded_iff sup.coboundedI1 sup.mono sup_left_divisibility sup_right_divisibility sup_same_context)
  also have "... = n(yω) * L  y * y * y * z  y * w * n(xω) * L  y * w * x"
    by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup n_L_split star_mult_omega)
  also have "...  n(yω) * L  y * z  y * w * n(xω) * L  y * w * x"
    by (meson mult_left_isotone order_refl semiring.add_left_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_left_isotone)
  finally have 2: "z * x  n(yω) * L  y * z  y * w * n(xω) * L  y * w * x"
    by (smt le_supI1 le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
  have "z * x * xω  n(yω) * L  y * y * z * xω  w * xω"
    using 1 by (smt (verit, del_insts) L_left_zero mult_assoc mult_left_isotone mult_right_dist_sup)
  hence "n(z * x * xω)  n(y * y * z * xω  n(yω) * L  w * xω)"
    by (simp add: n_isotone sup_commute)
  hence "n(z * xω)  n(yω  y * w * xω)"
    by (smt (verit, del_insts) sup_assoc sup_commute left_plus_omega le_iff_sup mult_assoc mult_left_dist_sup n_L_decreasing n_omega_induct omega_unfold star.left_plus_circ star_mult_omega)
  hence "n(z * xω) * L  n(yω) * L  y * w * n(xω) * L"
    by (metis n_dist_sup n_galois n_mult n_n_L)
  hence "z * n(xω) * L  z * bot  n(yω) * L  y * w * n(xω) * L"
    using n_L_split semiring.add_left_mono sup_assoc by auto
  also have "...  n(yω) * L  y * z  y * w * n(xω) * L"
    by (smt (z3) order.trans mult_1_left mult_right_sub_dist_sup_left semiring.add_right_mono star_left_unfold_equal sup_commute zero_right_mult_decreasing)
  finally have "z * n(xω) * L  n(yω) * L  y * z  y * w * n(xω) * L  y * w * x"
    using le_supI1 by blast
  thus ?thesis
    using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed

lemma n_Omega_circ_simulate_left_sup:
  assumes "x * z  z * yΩ  w"
    shows "xΩ * z  (z  xΩ * w) * yΩ"
proof -
  have "x * (z * n(yω) * L  z * y  n(xω) * L  x * w * n(yω) * L  x * w * y) = x * z * n(yω) * L  x * z * y  n(xω) * L  x * x * w * n(yω) * L  x * x * w * y"
    by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup n_L_split omega_unfold)
  also have "...  (z * n(yω) * L  z * y  w) * n(yω) * L  (z * n(yω) * L  z * y  w) * y  n(xω) * L  x * w * n(yω) * L  x * w * y"
    by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
  also have "... = z * n(yω) * L  z * y * n(yω) * L  w * n(yω) * L  z * y  w * y  n(xω) * L  x * w * n(yω) * L  x * w * y"
    by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
  also have "... = z * n(yω) * L  w * n(yω) * L  z * y  w * y  n(xω) * L  x * w * n(yω) * L  x * w * y"
    by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc n_L_split star_mult_omega zero_right_mult_decreasing)
  finally have "x * (z * n(yω) * L  z * y  n(xω) * L  x * w * n(yω) * L  x * w * y)  z * n(yω) * L  z * y  n(xω) * L  x * w * n(yω) * L  x * w * y"
    by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
  thus "xΩ * z  (z  xΩ * w) * yΩ"
    by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_supI1 le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed

end

text ‹Theorem 2.6 and Theorem 19›

sublocale n_omega_algebra_2 < nL_omega: itering where circ = Omega
  apply unfold_locales
  apply (simp add: n_Omega_circ_sup)
  apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup n_L_split omega_slide star.circ_mult)
  apply (simp add: n_Omega_circ_simulate_right_sup)
  using n_Omega_circ_simulate_left_sup by auto

sublocale n_omega_algebra_2 < nL_omega: n_omega_itering where circ = Omega
  apply unfold_locales
  by (smt Omega_def sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_left_one n_L_split n_top ni_below_L ni_def star_involutive star_mult_omega star_omega_top zero_right_mult_decreasing)

sublocale n_omega_algebra_2 < nL_omega: left_zero_kleene_conway_semiring where circ = Omega ..

sublocale n_omega_algebra_2 < nL_star: left_omega_conway_semiring where circ = star ..

context n_omega_algebra_2
begin

lemma circ_sup_8:
  "n((x * y) * xω) * L  (x * y)Ω * xΩ"
  by (metis sup_ge1 nL_omega.circ_sup_4 Omega_def mult_left_isotone n_isotone omega_sum_unfold_3 order_trans)

lemma n_split_omega_omega:
  "xω  xω * bot  n(xω) * top"
  by (metis n_split n_top_L omega_vector)

text ‹Theorem 20.1›

lemma n_below_n_star:
  "n(x)  n(x)"
  by (simp add: n_isotone star.circ_increasing)

text ‹Theorem 20.2›

lemma n_star_below_n_omega:
  "n(x)  n(xω)"
  by (metis n_mult_left_upper_bound star_mult_omega)

lemma n_below_n_omega:
  "n(x)  n(xω)"
  using order.trans n_below_n_star n_star_below_n_omega by blast

text ‹Theorem 20.4›

lemma star_n_L:
  "x * n(x) * L = x * bot"
  by (metis sup_bot_left mult_left_zero n_L_split n_dist_sup n_mult_bot n_one ni_def ni_split star_left_unfold_equal star_plus)

lemma star_L_split:
  assumes "y  z"
      and "x * z * L  x * bot  z * L"
    shows "x * y * L  x * bot  z * L"
proof -
  have "x * (x * bot  z * L)  x * bot  x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "...  x * bot  x * bot  z * L"
    using assms(2) semiring.add_left_mono sup_assoc by auto
  also have "... = x * bot  z * L"
    using mult_left_isotone star.circ_increasing sup.absorb_iff2 sup_commute by auto
  finally have "y * L  x * (x * bot  z * L)  x * bot  z * L"
    by (metis assms(1) le_sup_iff sup_ge2 mult_left_isotone order_trans)
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma star_L_split_same:
  "x * y * L  x * bot  y * L  x * y * L = x * bot  y * L"
  apply (rule order.antisym)
  apply (simp add: star_L_split)
  by (metis bot_least le_supI mult_isotone nL_star.star_below_circ star.circ_loop_fixpoint sup.cobounded2 mult_assoc)

lemma star_n_L_split_equal:
  "n(x * y)  n(y)  x * n(y) * L = x * bot  n(y) * L"
  by (simp add: n_mult_right_upper_bound star_L_split_same)

lemma n_star_mult:
  "n(x * y)  n(y)  n(x * y) = n(x)  n(y)"
  by (metis n_dist_sup n_mult n_mult_bot n_n_L star_n_L_split_equal)

text ‹Theorem 20.3›

lemma n_omega_mult:
  "n(xω * y) = n(xω)"
  by (simp add: n_isotone n_mult_left_upper_bound omega_sub_vector order.eq_iff)

lemma n_star_left_unfold:
  "n(x) = n(x * x)"
  by (metis n_mult n_mult_bot star.circ_plus_same star_n_L)

lemma ni_star_below_ni_omega:
  "ni(x)  ni(xω)"
  by (simp add: ni_n_order n_star_below_n_omega)

lemma ni_below_ni_omega:
  "ni(x)  ni(xω)"
  by (simp add: ni_n_order n_below_n_omega)

lemma ni_star:
  "ni(x) = 1  ni(x)"
  by (simp add: mult_L_star ni_def)

lemma ni_omega:
  "ni(x)ω = ni(x)"
  using mult_L_omega ni_def by auto

lemma ni_omega_induct:
  "ni(y)  ni(x * y  z)  ni(y)  ni(xω  x * z)"
  using n_omega_induct ni_n_order by blast

lemma star_ni:
  "x * ni(x) = x * bot"
  using ni_def mult_assoc star_n_L by auto

lemma star_ni_split_equal:
  "ni(x * y)  ni(y)  x * ni(y) = x * bot  ni(y)"
  using ni_def ni_mult_right_upper_bound mult_assoc star_L_split_same by auto

lemma ni_star_mult:
  "ni(x * y)  ni(y)  ni(x * y) = ni(x)  ni(y)"
  using mult_right_dist_sup ni_def ni_n_order n_star_mult by auto

lemma ni_omega_mult:
  "ni(xω * y) = ni(xω)"
  by (simp add: ni_def n_omega_mult)

lemma ni_star_left_unfold:
  "ni(x) = ni(x * x)"
  by (simp add: ni_def n_star_left_unfold)

lemma n_star_import:
  assumes "n(y) * x  x * n(y)"
    shows "n(y) * x = n(y) * (n(y) * x)"
proof (rule order.antisym)
  have "n(y) * (n(y) * x) * x  n(y) * (n(y) * x)"
    by (smt assms mult_assoc mult_right_dist_sup mult_right_sub_dist_sup_left n_mult_idempotent n_preserves_equation star.circ_back_loop_fixpoint)
  thus "n(y) * x  n(y) * (n(y) * x)"
    using assms eq_refl n_mult_idempotent n_sub_one star.circ_import by auto
next
  show "n(y) * (n(y) * x)  n(y) * x"
    by (simp add: assms n_mult_idempotent n_sub_one star.circ_import)
qed

lemma n_omega_export:
  "n(y) * x  x * n(y)  n(y) * xω = (n(y) * x)ω"
  apply (rule order.antisym)
  apply (simp add: n_preserves_equation omega_simulation)
  by (metis mult_right_isotone mult_1_right n_sub_one omega_isotone omega_slide)

lemma n_omega_import:
  "n(y) * x  x * n(y)  n(y) * xω = n(y) * (n(y) * x)ω"
  by (simp add: n_mult_idempotent omega_import)

text ‹Theorem 20.5›

lemma star_n_omega_top:
  "x * n(xω) * top = x * bot  n(xω) * top"
  by (smt (verit, del_insts) le_supI le_sup_iff sup_right_divisibility order.antisym mult_assoc nL_star.circ_mult_omega nL_star.star_zero_below_circ_mult n_top_split star.circ_loop_fixpoint)

(*
lemma n_star_induct_sup: "n(z ⊔ x * y) ≤ n(y) ⟹ n(x * z) ≤ n(y)" oops
*)

end

end

Theory N_Semirings_Boolean

(* Title:      Boolean N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Boolean N-Semirings›

theory N_Semirings_Boolean

imports N_Semirings

begin

class an =
  fixes an :: "'a  'a"

class an_semiring = bounded_idempotent_left_zero_semiring + L + n + an + uminus +
  assumes an_complement: "an(x)  n(x) = 1"
  assumes an_dist_sup  : "an(x  y) = an(x) * an(y)"
  assumes an_export    : "an(an(x) * y) = n(x)  an(y)"
  assumes an_mult_zero : "an(x) = an(x * bot)"
  assumes an_L_split   : "x * n(y) * L = x * bot  n(x * y) * L"
  assumes an_split     : "an(x * L) * x  x * bot"
  assumes an_uminus    : "-x = an(x * L)"
begin

text ‹Theorem 21›

lemma n_an_def:
  "n(x) = an(an(x) * L)"
  by (metis an_dist_sup an_export an_split bot_least mult_right_isotone semiring.add_nonneg_eq_0_iff sup.orderE top_greatest vector_bot_closed)

text ‹Theorem 21›

lemma an_complement_bot:
  "an(x) * n(x) = bot"
  by (metis an_dist_sup an_split bot_least le_iff_sup mult_left_zero sup_commute n_an_def)

text ‹Theorem 21›

lemma an_n_def:
  "an(x) = n(an(x) * L)"
  by (smt (verit, ccfv_threshold) an_complement_bot an_complement mult.right_neutral mult_left_dist_sup mult_right_dist_sup sup_commute n_an_def)

lemma an_case_split_left:
  "an(z) * x  y  n(z) * x  y  x  y"
  by (metis le_sup_iff an_complement mult_left_one mult_right_dist_sup)

lemma an_case_split_right:
  "x * an(z)  y  x * n(z)  y  x  y"
  by (metis le_sup_iff an_complement mult_1_right mult_left_dist_sup)

lemma split_sub:
  "x * y  z  x * top"
  by (simp add: le_supI2 mult_right_isotone)

text ‹Theorem 21›

subclass n_semiring
  apply unfold_locales
  apply (metis an_dist_sup an_split mult_left_zero sup.absorb2 sup_bot_left sup_commute n_an_def)
  apply (metis sup_left_top an_complement an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export an_n_def mult_right_dist_sup n_an_def)
  apply (metis sup_idem an_dist_sup an_mult_zero n_an_def)
  apply (simp add: an_L_split)
  by (meson an_case_split_left an_split le_supI1 split_sub)

lemma n_complement_bot:
  "n(x) * an(x) = bot"
  by (metis an_complement_bot an_n_def n_an_def)

lemma an_bot:
  "an(bot) = 1"
  by (metis sup_bot_right an_complement n_bot)

lemma an_one:
  "an(1) = 1"
  by (metis sup_bot_right an_complement n_one)

lemma an_L:
  "an(L) = bot"
  using an_one n_one n_an_def by auto

lemma an_top:
  "an(top) = bot"
  by (metis mult_left_one n_complement_bot n_top)

lemma an_export_n:
  "an(n(x) * y) = an(x)  an(y)"
  by (metis an_export an_n_def n_an_def)

lemma n_export_an:
  "n(an(x) * y) = an(x) * n(y)"
  by (metis an_n_def n_export)

lemma n_an_mult_commutative:
  "n(x) * an(y) = an(y) * n(x)"
  by (metis sup_commute an_dist_sup n_an_def)

lemma an_mult_commutative:
  "an(x) * an(y) = an(y) * an(x)"
  by (metis sup_commute an_dist_sup)

lemma an_mult_idempotent:
  "an(x) * an(x) = an(x)"
  by (metis sup_idem an_dist_sup)

lemma an_sub_one:
  "an(x)  1"
  using an_complement sup.cobounded1 by fastforce

text ‹Theorem 21›

lemma an_antitone:
  "x  y  an(y)  an(x)"
  by (metis an_n_def an_dist_sup n_order sup.absorb1)

lemma an_mult_left_upper_bound:
  "an(x * y)  an(x)"
  by (metis an_antitone an_mult_zero mult_right_isotone bot_least)

lemma an_mult_right_zero:
  "an(x) * bot = bot"
  by (metis an_n_def n_mult_right_bot)

lemma n_mult_an:
  "n(x * an(y)) = n(x)"
  by (metis an_n_def n_mult_n)

lemma an_mult_n:
  "an(x * n(y)) = an(x)"
  by (metis an_n_def n_an_def n_mult_n)

lemma an_mult_an:
  "an(x * an(y)) = an(x)"
  by (metis an_mult_n an_n_def)

lemma an_mult_left_absorb_sup:
  "an(x) * (an(x)  an(y)) = an(x)"
  by (metis an_n_def n_mult_left_absorb_sup)

lemma an_mult_right_absorb_sup:
  "(an(x)  an(y)) * an(y) = an(y)"
  by (metis an_n_def n_mult_right_absorb_sup)

lemma an_sup_left_absorb_mult:
  "an(x)  an(x) * an(y) = an(x)"
  using an_case_split_right sup_absorb1 by blast

lemma an_sup_right_absorb_mult:
  "an(x) * an(y)  an(y) = an(y)"
  using an_case_split_left sup_absorb2 by blast

lemma an_sup_left_dist_mult:
  "an(x)  an(y) * an(z) = (an(x)  an(y)) * (an(x)  an(z))"
  by (metis an_n_def n_sup_left_dist_mult)

lemma an_sup_right_dist_mult:
  "an(x) * an(y)  an(z) = (an(x)  an(z)) * (an(y)  an(z))"
  by (simp add: an_sup_left_dist_mult sup_commute)

lemma an_n_order:
  "an(x)  an(y)  n(y)  n(x)"
  by (smt (verit) an_n_def an_dist_sup le_iff_sup n_dist_sup n_mult_right_absorb_sup sup.orderE n_an_def)

lemma an_order:
  "an(x)  an(y)  an(x) * an(y) = an(x)"
  by (metis an_n_def n_order)

lemma an_mult_left_lower_bound:
  "an(x) * an(y)  an(x)"
  using an_case_split_right by blast

lemma an_mult_right_lower_bound:
  "an(x) * an(y)  an(y)"
  by (simp add: an_sup_right_absorb_mult le_iff_sup)

lemma an_n_mult_left_lower_bound:
  "an(x) * n(y)  an(x)"
  using an_case_split_right by blast

lemma an_n_mult_right_lower_bound:
  "an(x) * n(y)  n(y)"
  using an_case_split_left by auto

lemma n_an_mult_left_lower_bound:
  "n(x) * an(y)  n(x)"
  using an_case_split_right by auto

lemma n_an_mult_right_lower_bound:
  "n(x) * an(y)  an(y)"
  using an_case_split_left by blast

lemma an_mult_least_upper_bound:
  "an(x)  an(y)  an(x)  an(z)  an(x)  an(y) * an(z)"
  by (metis an_mult_idempotent an_mult_left_lower_bound an_mult_right_lower_bound order.trans mult_isotone)

lemma an_mult_left_divisibility:
  "an(x)  an(y)  (z . an(x) = an(y) * an(z))"
  by (metis an_mult_commutative an_mult_left_lower_bound an_order)

lemma an_mult_right_divisibility:
  "an(x)  an(y)  (z . an(x) = an(z) * an(y))"
  by (simp add: an_mult_commutative an_mult_left_divisibility)

lemma an_split_top:
  "an(x * L) * x * top  x * bot"
  by (metis an_split mult_assoc mult_left_isotone mult_left_zero)

lemma an_n_L:
  "an(n(x) * L) = an(x)"
  using an_n_def n_an_def by auto

lemma an_galois:
  "an(y)  an(x)  n(x) * L  y"
  by (simp add: an_n_order n_galois)

lemma an_mult:
  "an(x * n(y) * L) = an(x * y)"
  by (metis an_n_L n_mult)

lemma n_mult_top:
  "an(x * n(y) * top) = an(x * y)"
  by (metis an_n_L n_mult_top)

lemma an_n_equal:
  "an(x) = an(y)  n(x) = n(y)"
  by (metis an_n_L n_an_def)

lemma an_top_L:
  "an(x * top) = an(x * L)"
  by (simp add: an_n_equal n_top_L)

lemma an_case_split_left_equal:
  "an(z) * x = an(z) * y  n(z) * x = n(z) * y  x = y"
  using an_complement case_split_left_equal by blast

lemma an_case_split_right_equal:
  "x * an(z) = y * an(z)  x * n(z) = y * n(z)  x = y"
  using an_complement case_split_right_equal by blast

lemma an_equal_complement:
  "n(x)  an(y) = 1  n(x) * an(y) = bot  an(x) = an(y)"
  by (metis sup_commute an_complement an_dist_sup mult_left_one mult_right_dist_sup n_complement_bot)

lemma n_equal_complement:
  "n(x)  an(y) = 1  n(x) * an(y) = bot  n(x) = n(y)"
  by (simp add: an_equal_complement an_n_equal)

lemma an_shunting:
  "an(z) * x  y  x  y  n(z) * top"
  apply (rule iffI)
  apply (meson an_case_split_left le_supI1 split_sub)
  by (metis sup_bot_right an_case_split_left an_complement_bot mult_assoc mult_left_dist_sup mult_left_zero mult_right_isotone order_refl order_trans)

lemma an_shunting_an:
  "an(z) * an(x)  an(y)  an(x)  n(z)  an(y)"
  apply (rule iffI)
  apply (smt sup_ge1 sup_ge2 an_case_split_left n_an_mult_left_lower_bound order_trans)
  by (metis sup_bot_left sup_ge2 an_case_split_left an_complement_bot mult_left_dist_sup mult_right_isotone order_trans)

lemma an_L_zero:
  "an(x * L) * x = an(x * L) * x * bot"
  by (metis an_complement_bot n_split_equal sup_monoid.add_0_right vector_bot_closed mult_assoc n_export_an)

lemma n_plus_complement_intro_n:
  "n(x)  an(x) * n(y) = n(x)  n(y)"
  by (metis sup_commute an_complement an_n_def mult_1_right n_sup_right_dist_mult n_an_mult_commutative)

lemma n_plus_complement_intro_an:
  "n(x)  an(x) * an(y) = n(x)  an(y)"
  by (metis an_n_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_n:
  "an(x)  n(x) * n(y) = an(x)  n(y)"
  by (metis an_n_def n_an_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_an:
  "an(x)  n(x) * an(y) = an(x)  an(y)"
  by (metis an_n_def an_plus_complement_intro_n)

lemma n_mult_complement_intro_n:
  "n(x) * (an(x)  n(y)) = n(x) * n(y)"
  by (simp add: mult_left_dist_sup n_complement_bot)

lemma n_mult_complement_intro_an:
  "n(x) * (an(x)  an(y)) = n(x) * an(y)"
  by (simp add: semiring.distrib_left n_complement_bot)

lemma an_mult_complement_intro_n:
  "an(x) * (n(x)  n(y)) = an(x) * n(y)"
  by (simp add: an_complement_bot mult_left_dist_sup)

lemma an_mult_complement_intro_an:
  "an(x) * (n(x)  an(y)) = an(x) * an(y)"
  by (simp add: an_complement_bot semiring.distrib_left)

lemma an_preserves_equation:
  "an(y) * x  x * an(y)  an(y) * x = an(y) * x * an(y)"
  by (metis an_n_def n_preserves_equation)

lemma wnf_lemma_1:
  "(n(p * L) * n(q * L)  an(p * L) * an(r * L)) * n(p * L) = n(p * L) * n(q * L)"
  by (smt sup_commute an_n_def n_sup_left_absorb_mult n_sup_right_dist_mult n_export n_mult_commutative n_mult_complement_intro_n)

lemma wnf_lemma_2:
  "(n(p * L) * n(q * L)  an(r * L) * an(q * L)) * n(q * L) = n(p * L) * n(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_1)

lemma wnf_lemma_3:
  "(n(p * L) * n(r * L)  an(p * L) * an(q * L)) * an(p * L) = an(p * L) * an(q * L)"
  by (metis an_n_def sup_commute wnf_lemma_1 n_an_def)

lemma wnf_lemma_4:
  "(n(r * L) * n(q * L)  an(p * L) * an(q * L)) * an(q * L) = an(p * L) * an(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_3)

lemma wnf_lemma_5:
  "n(p  q) * (n(q) * x  an(q) * y) = n(q) * x  an(q) * n(p) * y"
  by (smt sup_bot_right mult_assoc mult_left_dist_sup n_an_mult_commutative n_complement_bot n_dist_sup n_mult_right_absorb_sup)

definition ani :: "'a  'a"
  where "ani x  an(x) * L"

lemma ani_bot:
  "ani(bot) = L"
  using an_bot ani_def by auto

lemma ani_one:
  "ani(1) = L"
  using an_one ani_def by auto

lemma ani_L:
  "ani(L) = bot"
  by (simp add: an_L ani_def)

lemma ani_top:
  "ani(top) = bot"
  by (simp add: an_top ani_def)

lemma ani_complement:
  "ani(x)  ni(x) = L"
  by (metis an_complement ani_def mult_right_dist_sup n_top ni_def ni_top)

lemma ani_mult_zero:
  "ani(x) = ani(x * bot)"
  using ani_def an_mult_zero by auto

lemma ani_antitone:
  "y  x  ani(x)  ani(y)"
  by (simp add: an_antitone ani_def mult_left_isotone)

lemma ani_mult_left_upper_bound:
  "ani(x * y)  ani(x)"
  by (simp add: an_mult_left_upper_bound ani_def mult_left_isotone)

lemma ani_involutive:
  "ani(ani(x)) = ni(x)"
  by (simp add: ani_def ni_def n_an_def)

lemma ani_below_L:
  "ani(x)  L"
  using an_case_split_left ani_def by auto

lemma ani_left_zero:
  "ani(x) * y = ani(x)"
  by (simp add: ani_def L_left_zero mult_assoc)

lemma ani_top_L:
  "ani(x * top) = ani(x * L)"
  by (simp add: an_top_L ani_def)

lemma ani_ni_order:
  "ani(x)  ani(y)  ni(y)  ni(x)"
  by (metis an_n_L ani_antitone ani_def ani_involutive ni_def)

lemma ani_ni_equal:
  "ani(x) = ani(y)  ni(x) = ni(y)"
  by (metis ani_ni_order order.antisym order_refl)

lemma ni_ani:
  "ni(ani(x)) = ani(x)"
  using an_n_def ani_def ni_def by auto

lemma ani_ni:
  "ani(ni(x)) = ani(x)"
  by (simp add: an_n_L ani_def ni_def)

lemma ani_mult:
  "ani(x * ni(y)) = ani(x * y)"
  using ani_ni_equal ni_mult by blast

lemma ani_an_order:
  "ani(x)  ani(y)  an(x)  an(y)"
  using an_galois ani_ni_order ni_def ni_galois by auto

lemma ani_an_equal:
  "ani(x) = ani(y)  an(x) = an(y)"
  by (metis an_n_def ani_def)

lemma n_mult_ani:
  "n(x) * ani(x) = bot"
  by (metis an_L ani_L ani_def mult_assoc n_complement_bot)

lemma an_mult_ni:
  "an(x) * ni(x) = bot"
  by (metis an_n_def ani_def n_an_def n_mult_ani ni_def)

lemma n_mult_ni:
  "n(x) * ni(x) = ni(x)"
  by (metis n_export n_order ni_def ni_export order_refl)

lemma an_mult_ani:
  "an(x) * ani(x) = ani(x)"
  by (metis an_n_def ani_def n_mult_ni ni_def)

lemma ani_ni_meet:
  "x  ani(y)  x  ni(y)  x = bot"
  by (metis an_case_split_left an_mult_ni bot_unique mult_right_isotone n_mult_ani)

lemma ani_galois:
  "ani(x)  y  ni(x  y) = L"
  apply (rule iffI)
  apply (smt (z3) an_L an_mult_commutative an_mult_right_zero ani_def an_dist_sup ni_L ni_n_equal sup.absorb1 mult_assoc n_an_def n_complement_bot)
  by (metis an_L an_galois an_mult_ni an_n_def an_shunting_an ani_def an_dist_sup an_export idempotent_bot_closed n_bot transitive_bot_closed)

lemma an_ani:
  "an(ani(x)) = n(x)"
  by (simp add: ani_def n_an_def)

lemma n_ani:
  "n(ani(x)) = an(x)"
  using an_n_def ani_def by auto

lemma an_ni:
  "an(ni(x)) = an(x)"
  by (simp add: an_n_L ni_def)

lemma ani_an:
  "ani(an(x)) = L"
  by (metis an_mult_right_zero an_mult_zero an_bot ani_def mult_left_one)

lemma ani_n:
  "ani(n(x)) = L"
  by (simp add: ani_an n_an_def)

lemma ni_an:
  "ni(an(x)) = bot"
  using an_L ani_an ani_def ni_n_bot n_an_def by force

lemma ani_mult_n:
  "ani(x * n(y)) = ani(x)"
  by (simp add: an_mult_n ani_def)

lemma ani_mult_an:
  "ani(x * an(y)) = ani(x)"
  by (simp add: an_mult_an ani_def)

lemma ani_export_n:
  "ani(n(x) * y) = ani(x)  ani(y)"
  by (simp add: an_export_n ani_def mult_right_dist_sup)

lemma ani_export_an:
  "ani(an(x) * y) = ni(x)  ani(y)"
  by (simp add: ani_def an_export ni_def semiring.distrib_right)

lemma ni_export_an:
  "ni(an(x) * y) = an(x) * ni(y)"
  by (simp add: an_mult_right_zero ni_split)

lemma ani_mult_top:
  "ani(x * n(y) * top) = ani(x * y)"
  using ani_def n_mult_top by auto

lemma ani_an_bot:
  "ani(x) = bot  an(x) = bot"
  using an_L ani_L ani_an_equal by force

lemma ani_an_L:
  "ani(x) = L  an(x) = 1"
  using an_bot ani_an_equal ani_bot by force

text ‹Theorem 21›

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: an_mult_commutative an_uminus)
  apply (smt an_sup_left_dist_mult an_export_n an_n_L an_uminus n_an_def n_complement_bot n_export)
  apply (metis an_dist_sup an_n_def an_uminus n_an_def)
  using an_complement_bot an_uminus n_an_def apply fastforce
  apply (simp add: an_bot an_uminus)
  using an_export_n an_mult an_uminus n_an_def apply fastforce
  using an_order an_uminus apply force
  by (simp add: less_le_not_le)

end

class an_itering = n_itering + an_semiring + while +
  assumes while_circ_def: "p  y = (p * y) * -p"
begin

subclass test_itering
  apply unfold_locales
  by (rule while_circ_def)

lemma an_circ_left_unfold:
  "an(x) = an(x * x)"
  by (metis an_dist_sup an_one circ_left_unfold mult_left_one)

lemma an_circ_x_n_circ:
  "an(x) * x * n(x)  x * bot"
  by (metis an_circ_left_unfold an_mult an_split mult_assoc n_mult_right_bot)

lemma an_circ_invariant:
  "an(x) * x  x * an(x)"
proof -
  have 1: "an(x) * x * an(x)  x * an(x)"
    by (metis an_case_split_left mult_assoc order_refl)
  have "an(x) * x * n(x)  x * an(x)"
    by (metis an_circ_x_n_circ order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by blast
qed

lemma ani_circ:
  "ani(x) = 1  ani(x)"
  by (simp add: ani_def mult_L_circ)

lemma ani_circ_left_unfold:
  "ani(x) = ani(x * x)"
  by (simp add: an_circ_left_unfold ani_def)

lemma an_circ_import:
  "an(y) * x  x * an(y)  an(y) * x = an(y) * (an(y) * x)"
  by (metis an_n_def n_circ_import)

lemma preserves_L:
  "preserves L (-p)"
  using L_left_zero preserves_equation_test mult_assoc by force

end

class an_omega_algebra = n_omega_algebra_2 + an_semiring + while +
  assumes while_Omega_def: "p  y = (p * y)Ω * -p"
begin

lemma an_split_omega_omega:
  "an(xω) * xω  xω * bot"
  by (meson an_antitone an_split mult_left_isotone omega_sub_vector order_trans)

lemma an_omega_below_an_star:
  "an(xω)  an(x)"
  by (simp add: an_n_order n_star_below_n_omega)

lemma an_omega_below_an:
  "an(xω)  an(x)"
  by (simp add: an_n_order n_below_n_omega)

lemma an_omega_induct:
  "an(x * y  z)  an(y)  an(xω  x * z)  an(y)"
  by (simp add: an_n_order n_omega_induct)

lemma an_star_mult:
  "an(y)  an(x * y)  an(x * y) = an(x) * an(y)"
  by (metis an_dist_sup an_n_L an_n_order n_dist_sup n_star_mult)

lemma an_omega_mult:
  "an(xω * y) = an(xω)"
  by (simp add: an_n_equal n_omega_mult)

lemma an_star_left_unfold:
  "an(x) = an(x * x)"
  by (simp add: an_n_equal n_star_left_unfold)

lemma an_star_x_n_star:
  "an(x) * x * n(x)  x * bot"
  by (metis an_n_L an_split n_mult n_mult_right_bot n_star_left_unfold mult_assoc)

lemma an_star_invariant:
  "an(x) * x  x * an(x)"
proof -
  have 1: "an(x) * x * an(x)  x * an(x)"
    using an_case_split_left mult_assoc by auto
  have "an(x) * x * n(x)  x * an(x)"
    by (metis an_star_x_n_star order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by auto
qed

lemma n_an_star_unfold_invariant:
  "n(an(x) * xω)  an(x) * n(x * an(x) * xω)"
proof -
  have "n(an(x) * xω)  an(x)"
    using an_star_left_unfold an_case_split_right an_mult_left_upper_bound n_export_an by fastforce
  thus ?thesis
    by (smt an_star_invariant le_iff_sup mult_assoc mult_right_dist_sup n_isotone n_order omega_unfold)
qed

lemma ani_omega_below_ani_star:
  "ani(xω)  ani(x)"
  by (simp add: an_omega_below_an_star ani_an_order)

lemma ani_omega_below_ani:
  "ani(xω)  ani(x)"
  by (simp add: an_omega_below_an ani_an_order)

lemma ani_star:
  "ani(x) = 1  ani(x)"
  by (simp add: ani_def mult_L_star)

lemma ani_omega:
  "ani(x)ω = ani(x) * L"
  by (simp add: L_left_zero ani_def mult_L_omega mult_assoc)

lemma ani_omega_induct:
  "ani(x * y  z)  ani(y)  ani(xω  x * z)  ani(y)"
  by (simp add: an_omega_induct ani_an_order)

lemma ani_omega_mult:
  "ani(xω * y) = ani(xω)"
  by (simp add: an_omega_mult ani_def)

lemma ani_star_left_unfold:
  "ani(x) = ani(x * x)"
  by (simp add: an_star_left_unfold ani_def)

lemma an_star_import:
  "an(y) * x  x * an(y)  an(y) * x = an(y) * (an(y) * x)"
  by (metis an_n_def n_star_import)

lemma an_omega_export:
  "an(y) * x  x * an(y)  an(y) * xω = (an(y) * x)ω"
  by (metis an_n_def n_omega_export)

lemma an_omega_import:
  "an(y) * x  x * an(y)  an(y) * xω = an(y) * (an(y) * x)ω"
  by (simp add: an_mult_idempotent omega_import)

end

text ‹Theorem 22›

sublocale an_omega_algebra < nL_omega: an_itering where circ = Omega
  apply unfold_locales
  by (rule while_Omega_def)

context an_omega_algebra
begin

lemma preserves_star:
  "nL_omega.preserves x (-p)  nL_omega.preserves (x) (-p)"
  by (simp add: nL_omega.preserves_def star.circ_simulate)

end

end

Theory N_Semirings_Modal

(* Title:      Modal N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Modal N-Semirings›

theory N_Semirings_Modal

imports N_Semirings_Boolean

begin

class n_diamond_semiring = n_semiring + diamond +
  assumes ndiamond_def: "|x>y = n(x * y * L)"
begin

lemma diamond_x_bot:
  "|x>bot = n(x)"
  using n_mult_bot ndiamond_def mult_assoc by auto

lemma diamond_x_1:
  "|x>1 = n(x * L)"
  by (simp add: ndiamond_def)

lemma diamond_x_L:
  "|x>L = n(x * L)"
  by (simp add: L_left_zero ndiamond_def mult_assoc)

lemma diamond_x_top:
  "|x>top = n(x * L)"
  by (metis mult_assoc n_top_L ndiamond_def top_mult_top)

lemma diamond_x_n:
  "|x>n(y) = n(x * y)"
  by (simp add: n_mult ndiamond_def)

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: n_bot ndiamond_def)

lemma diamond_1_y:
  "|1>y = n(y * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_n:
  "|1>n(y) = n(y)"
  by (simp add: diamond_1_y n_n_L)

lemma diamond_L_y:
  "|L>y = 1"
  by (simp add: L_left_zero n_L ndiamond_def)

lemma diamond_top_y:
  "|top>y = 1"
  by (metis sup_left_top sup_right_top diamond_L_y mult_right_dist_sup n_dist_sup n_top ndiamond_def)

lemma diamond_n_y:
  "|n(x)>y = n(x) * n(y * L)"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_n_bot:
  "|n(x)>bot = bot"
  by (simp add: n_bot n_mult_right_bot ndiamond_def)

lemma diamond_n_1:
  "|n(x)>1 = n(x)"
  using diamond_1_n diamond_1_y diamond_x_1 by auto

lemma diamond_n_n:
  "|n(x)>n(y) = n(x) * n(y)"
  by (simp add: diamond_x_n n_export)

lemma diamond_n_n_same:
  "|n(x)>n(x) = n(x)"
  by (simp add: diamond_n_n n_mult_idempotent)

text ‹Theorem 23.1›

lemma diamond_left_dist_sup:
  "|x  y>z = |x>z  |y>z"
  by (simp add: mult_right_dist_sup n_dist_sup ndiamond_def)

text ‹Theorem 23.2›

lemma diamond_right_dist_sup:
  "|x>(y  z) = |x>y  |x>z"
  by (simp add: mult_left_dist_sup n_dist_sup ndiamond_def semiring.distrib_right)

text ‹Theorem 23.3›

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: ndiamond_def mult_assoc)

text ‹Theorem 23.3›

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using n_mult_ni ndiamond_def ni_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by force

lemma diamond_n_export:
  "|n(x) * y>z = n(x) * |y>z"
  by (simp add: n_export ndiamond_def mult_assoc)

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_n_y ndiamond_def by auto

lemma diamond_left_isotone:
  "x  y  |x>z  |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

lemma diamond_right_isotone:
  "y  z  |x>y  |x>z"
  by (metis diamond_right_dist_sup le_iff_sup)

lemma diamond_isotone:
  "w  y  x  z  |w>x  |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

definition ndiamond_L :: "'a  'a  'a" (" _ » _" [50,90] 95)
  where "x»y  n(x * y) * L"

lemma ndiamond_to_L:
  "x»y = |x>n(y) * L"
  by (simp add: diamond_x_n ndiamond_L_def)

lemma ndiamond_from_L:
  "|x>y = n(x»(y * L))"
  by (simp add: n_n_L ndiamond_def mult_assoc ndiamond_L_def)

lemma diamond_L_ni:
  "x»y = ni(x * y)"
  by (simp add: ni_def ndiamond_L_def)

lemma diamond_L_associative:
  "x * y»z = x»(y * z)"
  by (simp add: diamond_L_ni mult_assoc)

lemma diamond_L_left_mult:
  "x * y»z = x»y»z"
  using diamond_L_associative diamond_L_ni ni_mult by auto

lemma diamond_L_right_mult:
  "x»(y * z) = x»y»z"
  using diamond_L_associative diamond_L_left_mult by auto

lemma diamond_L_left_dist_sup:
  "x  y»z = x»z  y»z"
  by (simp add: diamond_L_ni mult_right_dist_sup ni_dist_sup)

lemma diamond_L_x_ni:
  "x»ni(y) = ni(x * y)"
  using n_mult_ni ni_def ndiamond_L_def by auto

lemma diamond_L_left_isotone:
  "x  y  x»z  y»z"
  using mult_left_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_right_isotone:
  "y  z  x»y  x»z"
  using mult_right_isotone ni_def ni_isotone ndiamond_L_def by auto

lemma diamond_L_isotone:
  "w  y  x  z  w»x  y»z"
  using diamond_L_ni mult_isotone ni_isotone by force

end

class n_box_semiring = n_diamond_semiring + an_semiring + box +
  assumes nbox_def: "|x]y = an(x * an(y * L) * L)"
begin

text ‹Theorem 23.8›

lemma box_diamond:
  "|x]y = an( |x>an(y * L) * L)"
  by (simp add: an_n_L nbox_def ndiamond_def)

text ‹Theorem 23.4›

lemma diamond_box:
  "|x>y = an( |x]an(y * L) * L)"
  using n_an_def n_mult nbox_def ndiamond_def mult_assoc by force

lemma box_x_bot:
  "|x]bot = an(x * L)"
  by (simp add: an_bot nbox_def)

lemma box_x_1:
  "|x]1 = an(x)"
  using an_L an_mult_an nbox_def mult_assoc by auto

lemma box_x_L:
  "|x]L = an(x)"
  using box_x_1 L_left_zero nbox_def by auto

lemma box_x_top:
  "|x]top = an(x)"
  by (metis box_diamond box_x_1 box_x_bot diamond_top_y)

lemma box_x_n:
  "|x]n(y) = an(x * an(y) * L)"
  by (simp add: an_n_L nbox_def)

lemma box_x_an:
  "|x]an(y) = an(x * y)"
  using an_mult n_an_def nbox_def by auto

lemma box_bot_y:
  "|bot]y = 1"
  by (simp add: an_bot nbox_def)

lemma box_1_y:
  "|1]y = n(y * L)"
  by (simp add: n_an_def nbox_def)

lemma box_1_n:
  "|1]n(y) = n(y)"
  using box_1_y diamond_1_n diamond_1_y by auto

lemma box_1_an:
  "|1]an(y) = an(y)"
  by (simp add: box_x_an)

lemma box_L_y:
  "|L]y = bot"
  by (simp add: L_left_zero an_L nbox_def)

lemma box_top_y:
  "|top]y = bot"
  by (simp add: box_diamond an_L diamond_top_y)

lemma box_n_y:
  "|n(x)]y = an(x)  n(y * L)"
  using an_export_n n_an_def nbox_def mult_assoc by auto

lemma box_an_y:
  "|an(x)]y = n(x)  n(y * L)"
  by (metis an_n_def box_n_y n_an_def)

lemma box_n_bot:
  "|n(x)]bot = an(x)"
  by (simp add: box_x_bot an_n_L)

lemma box_an_bot:
  "|an(x)]bot = n(x)"
  by (simp add: box_x_bot n_an_def)

lemma box_n_1:
  "|n(x)]1 = 1"
  using box_x_1 ani_an_L ani_n by auto

lemma box_an_1:
  "|an(x)]1 = 1"
  using box_x_1 ani_an ani_an_L by fastforce

lemma box_n_n:
  "|n(x)]n(y) = an(x)  n(y)"
  using box_1_n box_1_y box_n_y by auto

lemma box_an_n:
  "|an(x)]n(y) = n(x)  n(y)"
  using box_x_n an_dist_sup n_an_def n_dist_sup by auto

lemma box_n_an:
  "|n(x)]an(y) = an(x)  an(y)"
  by (simp add: box_x_an an_export_n)

lemma box_an_an:
  "|an(x)]an(y) = n(x)  an(y)"
  by (simp add: box_x_an an_export)

lemma box_n_n_same:
  "|n(x)]n(x) = 1"
  by (simp add: box_n_n an_complement)

lemma box_an_an_same:
  "|an(x)]an(x) = 1"
  using box_an_bot an_bot an_complement_bot nbox_def by auto

text ‹Theorem 23.5›

lemma box_left_dist_sup:
  "|x  y]z = |x]z * |y]z"
  using an_dist_sup nbox_def semiring.distrib_right by auto

lemma box_right_dist_sup:
  "|x](y  z) = an(x * an(y * L) * an(z * L) * L)"
  by (simp add: an_dist_sup mult_right_dist_sup nbox_def mult_assoc)

lemma box_associative:
  "|x * y]z = an(x * y * an(z * L) * L)"
  by (simp add: nbox_def)

text ‹Theorem 23.7›

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_an nbox_def mult_assoc by auto

lemma box_right_mult:
  "|x](y * z) = an(x * an(y * z * L) * L)"
  by (simp add: nbox_def)

text ‹Theorem 23.6›

lemma box_right_mult_n_n:
  "|x](n(y) * n(z)) = |x]n(y) * |x]n(z)"
  by (smt an_dist_sup an_export_n an_n_L mult_assoc mult_left_dist_sup mult_right_dist_sup nbox_def)

lemma box_right_mult_an_n:
  "|x](an(y) * n(z)) = |x]an(y) * |x]n(z)"
  by (metis an_n_def box_right_mult_n_n)

lemma box_right_mult_n_an:
  "|x](n(y) * an(z)) = |x]n(y) * |x]an(z)"
  by (simp add: box_right_mult_an_n box_x_an box_x_n an_mult_commutative n_an_mult_commutative)

lemma box_right_mult_an_an:
  "|x](an(y) * an(z)) = |x]an(y) * |x]an(z)"
  by (metis an_dist_sup box_x_an mult_left_dist_sup)

lemma box_n_export:
  "|n(x) * y]z = an(x)  |y]z"
  using box_left_mult box_n_an nbox_def by auto

lemma box_an_export:
  "|an(x) * y]z = n(x)  |y]z"
  using box_an_an box_left_mult nbox_def by auto

lemma box_left_antitone:
  "y  x  |x]z  |y]z"
  by (smt an_mult_commutative an_order box_diamond box_left_dist_sup le_iff_sup)

lemma box_right_isotone:
  "y  z  |x]y  |x]z"
  by (metis an_antitone mult_left_isotone mult_right_isotone nbox_def)

lemma box_antitone_isotone:
  "y  w  x  z  |w]x  |y]z"
  by (meson box_left_antitone box_right_isotone order.trans)

definition nbox_L :: "'a  'a  'a" (" _  _" [50,90] 95)
  where "xy  an(x * an(y) * L) * L"

lemma nbox_to_L:
  "xy = |x]n(y) * L"
  by (simp add: box_x_n nbox_L_def)

lemma nbox_from_L:
  "|x]y = n(x(y * L))"
  using an_n_def nbox_def nbox_L_def by auto

lemma diamond_x_an:
  "|x>an(y) = n(x * an(y) * L)"
  by (simp add: ndiamond_def)

lemma diamond_1_an:
  "|1>an(y) = an(y)"
  using box_1_an box_1_y diamond_1_y by auto

lemma diamond_an_y:
  "|an(x)>y = an(x) * n(y * L)"
  by (simp add: n_export_an ndiamond_def mult_assoc)

lemma diamond_an_bot:
  "|an(x)>bot = bot"
  by (simp add: an_mult_right_zero n_bot ndiamond_def)

lemma diamond_an_1:
  "|an(x)>1 = an(x)"
  using an_n_def diamond_x_1 by auto

lemma diamond_an_n:
  "|an(x)>n(y) = an(x) * n(y)"
  by (simp add: diamond_x_n n_export_an)

lemma diamond_n_an:
  "|n(x)>an(y) = n(x) * an(y)"
  using an_n_def diamond_n_y by auto

lemma diamond_an_an:
  "|an(x)>an(y) = an(x) * an(y)"
  using diamond_an_y an_n_def by auto

lemma diamond_an_an_same:
  "|an(x)>an(x) = an(x)"
  by (simp add: diamond_an_an an_mult_idempotent)

lemma diamond_an_export:
  "|an(x) * y>z = an(x) * |y>z"
  using diamond_an_an diamond_box diamond_left_mult by auto

lemma box_ani:
  "|x]y = an(x * ani(y * L))"
  by (simp add: ani_def nbox_def mult_assoc)

lemma box_x_n_ani:
  "|x]n(y) = an(x * ani(y))"
  by (simp add: box_x_n ani_def mult_assoc)

lemma box_L_ani:
  "xy = ani(x * ani(y))"
  using box_x_n_ani ani_def nbox_to_L by auto

lemma box_L_left_mult:
  "x * yz = xyz"
  using an_mult n_an_def mult_assoc nbox_L_def by auto

lemma diamond_x_an_ani:
  "|x>an(y) = n(x * ani(y))"
  by (simp add: ani_def ndiamond_def mult_assoc)

lemma box_L_left_antitone:
  "y  x  xz  yz"
  by (simp add: box_L_ani ani_antitone mult_left_isotone)

lemma box_L_right_isotone:
  "y  z  xy  xz"
  using ani_antitone ani_def mult_right_isotone mult_assoc nbox_L_def by auto

lemma box_L_antitone_isotone:
  "y  w  x  z  wx  yz"
  using ani_antitone ani_def mult_isotone mult_assoc nbox_L_def by force

end

class n_box_omega_algebra = n_box_semiring + an_omega_algebra
begin

lemma diamond_omega:
  "|xω>y = |xω>z"
  by (simp add: n_omega_mult ndiamond_def mult_assoc)

lemma box_omega:
  "|xω]y = |xω]z"
  by (metis box_diamond diamond_omega)

lemma an_box_omega_induct:
  "|x]an(y) * n(z * L)  an(y)  |xω  x]z  an(y)"
  by (smt an_dist_sup an_omega_induct an_omega_mult box_left_dist_sup box_x_an mult_assoc n_an_def nbox_def)

lemma n_box_omega_induct:
  "|x]n(y) * n(z * L)  n(y)  |xω  x]z  n(y)"
  by (simp add: an_box_omega_induct n_an_def)

lemma an_box_omega_induct_an:
  "|x]an(y) * an(z)  an(y)  |xω  x]an(z)  an(y)"
  using an_box_omega_induct an_n_def by auto

text ‹Theorem 23.13›

lemma n_box_omega_induct_n:
  "|x]n(y) * n(z)  n(y)  |xω  x]n(z)  n(y)"
  using an_box_omega_induct_an n_an_def by force

lemma n_diamond_omega_induct:
  "n(y)  |x>n(y)  n(z * L)  n(y)  |xω  x>z"
  using diamond_x_n mult_right_dist_sup n_dist_sup n_omega_induct n_omega_mult ndiamond_def mult_assoc by force

lemma an_diamond_omega_induct:
  "an(y)  |x>an(y)  n(z * L)  an(y)  |xω  x>z"
  by (metis n_diamond_omega_induct an_n_def)

text ‹Theorem 23.9›

lemma n_diamond_omega_induct_n:
  "n(y)  |x>n(y)  n(z)  n(y)  |xω  x>n(z)"
  using box_1_n box_1_y n_diamond_omega_induct by auto

lemma an_diamond_omega_induct_an:
  "an(y)  |x>an(y)  an(z)  an(y)  |xω  x>an(z)"
  using an_diamond_omega_induct an_n_def by auto

lemma box_segerberg_an:
  "|xω  x]an(y) = an(y) * |xω  x](n(y)  |x]an(y))"
proof (rule order.antisym)
  have "|xω  x]an(y)  |xω  x]|x]an(y)"
    by (smt box_left_dist_sup box_left_mult box_omega sup_right_isotone box_left_antitone mult_right_dist_sup star.right_plus_below_circ)
  hence "|xω  x]an(y)  |xω  x](n(y)  |x]an(y))"
    using box_right_isotone order_lesseq_imp sup.cobounded2 by blast
  thus"|xω  x]an(y)  an(y) * |xω  x](n(y)  |x]an(y))"
    by (metis le_sup_iff box_1_an box_left_antitone order_refl star_left_unfold_equal an_mult_least_upper_bound nbox_def)
next
  have "an(y) * |x](n(y)  |xω  x]an(y)) * (n(y)  |x]an(y)) = |x]( |xω  x]an(y) * an(y)) * an(y)"
    by (smt sup_bot_left an_export an_mult_commutative box_right_mult_an_an mult_assoc mult_right_dist_sup n_complement_bot nbox_def)
  hence 1: "an(y) * |x](n(y)  |xω  x]an(y)) * (n(y)  |x]an(y))  n(y)  |xω  x]an(y)"
    by (smt sup_assoc sup_commute sup_ge2 box_1_an box_left_dist_sup box_left_mult mult_left_dist_sup omega_unfold star_left_unfold_equal star.circ_plus_one)
  have "n(y) * |x](n(y)  |xω  x]an(y)) * (n(y)  |x]an(y))  n(y)  |xω  x]an(y)"
    by (smt sup_ge1 an_n_def mult_left_isotone n_an_mult_left_lower_bound n_mult_left_absorb_sup nbox_def order_trans)
  thus "an(y) * |xω  x](n(y)  |x]an(y))  |xω  x]an(y)"
    using 1 by (smt an_case_split_left an_shunting_an mult_assoc n_box_omega_induct_n n_dist_sup nbox_def nbox_from_L)
qed

text ‹Theorem 23.16›

lemma box_segerberg_n:
  "|xω  x]n(y) = n(y) * |xω  x](an(y)  |x]n(y))"
  using box_segerberg_an an_n_def n_an_def by force

lemma diamond_segerberg_an:
  "|xω  x>an(y) = an(y)  |xω  x>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_segerberg_an diamond_box mult_assoc n_an_def)

text ‹Theorem 23.12›

lemma diamond_segerberg_n:
  "|xω  x>n(y) = n(y)  |xω  x>(an(y) * |x>n(y))"
  using diamond_segerberg_an an_n_L n_an_def by auto

text ‹Theorem 23.11›

lemma diamond_star_unfold_n:
  "|x>n(y) = n(y)  |an(y) * x>|x>n(y)"
proof -
  have "|x>n(y) = n(y)  n(y) * |x * x>n(y)  |an(y) * x * x>n(y)"
    by (smt sup_assoc sup_commute sup_bot_right an_complement an_complement_bot diamond_an_n diamond_left_dist_sup diamond_n_export diamond_n_n_same mult_assoc mult_left_one mult_right_dist_sup star_left_unfold_equal)
  thus ?thesis
    by (metis diamond_left_mult diamond_x_n n_sup_left_absorb_mult)
qed

lemma diamond_star_unfold_an:
  "|x>an(y) = an(y)  |n(y) * x>|x>an(y)"
  by (metis an_n_def diamond_star_unfold_n n_an_def)

text ‹Theorem 23.15›

lemma box_star_unfold_n:
  "|x]n(y) = n(y) * |n(y) * x]|x]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_star_unfold_an n_an_def n_export)

lemma box_star_unfold_an:
  "|x]an(y) = an(y) * |an(y) * x]|x]an(y)"
  by (metis an_n_def box_star_unfold_n)

text ‹Theorem 23.10›

lemma diamond_omega_unfold_n:
  "|xω  x>n(y) = n(y)  |an(y) * x>|xω  x>n(y)"
  by (smt sup_assoc sup_commute diamond_an_export diamond_left_dist_sup diamond_right_dist_sup diamond_star_unfold_n diamond_x_n n_omega_mult n_plus_complement_intro_n omega_unfold)

lemma diamond_omega_unfold_an:
  "|xω  x>an(y) = an(y)  |n(y) * x>|xω  x>an(y)"
  by (metis an_n_def diamond_omega_unfold_n n_an_def)

text ‹Theorem 23.14›

lemma box_omega_unfold_n:
  "|xω  x]n(y) = n(y) * |n(y) * x]|xω  x]n(y)"
  by (smt an_export an_n_L box_diamond diamond_box diamond_omega_unfold_an n_an_def n_export)

lemma box_omega_unfold_an:
  "|xω  x]an(y) = an(y) * |an(y) * x]|xω  x]an(y)"
  by (metis an_n_def box_omega_unfold_n)

lemma box_cut_iteration_an:
  "|xω  x]an(y) = |(an(y) * x)ω  (an(y) * x)]an(y)"
  apply (rule order.antisym)
  apply (meson semiring.add_mono an_case_split_left box_left_antitone omega_isotone order_refl star.circ_isotone)
  by (smt (z3) an_box_omega_induct_an an_mult_commutative box_omega_unfold_an nbox_def order_refl)

lemma box_cut_iteration_n:
  "|xω  x]n(y) = |(n(y) * x)ω  (n(y) * x)]n(y)"
  using box_cut_iteration_an n_an_def by auto

lemma diamond_cut_iteration_an:
  "|xω  x>an(y) = |(n(y) * x)ω  (n(y) * x)>an(y)"
  using box_cut_iteration_n diamond_box n_an_def by auto

lemma diamond_cut_iteration_n:
  "|xω  x>n(y) = |(an(y) * x)ω  (an(y) * x)>n(y)"
  using box_cut_iteration_an an_n_L diamond_box by auto

lemma ni_diamond_omega_induct:
  "ni(y)  x»ni(y)  ni(z)  ni(y)  xω  x»z"
  by (metis diamond_L_left_dist_sup diamond_L_x_ni diamond_L_ni ni_dist_sup ni_omega_induct ni_omega_mult)

lemma ani_diamond_omega_induct:
  "ani(y)  x»ani(y)  ni(z)  ani(y)  xω  x»z"
  by (metis ni_ani ni_diamond_omega_induct)

lemma n_diamond_omega_L:
  "|n(xω) * L>y = |xω>y"
  using L_left_zero mult_1_right n_L n_export n_omega_mult ndiamond_def mult_assoc by auto

lemma n_diamond_loop:
  "|xΩ>y = |xω  x>y"
  by (metis Omega_def diamond_left_dist_sup n_diamond_omega_L)

text ‹Theorem 24.1›

lemma cut_iteration_loop:
  "|xΩ>n(y) = |(an(y) * x)Ω>n(y)"
  using diamond_cut_iteration_n n_diamond_loop by auto

lemma cut_iteration_while_loop:
  "|xΩ>n(y) = |(an(y) * x)Ω * n(y)>n(y)"
  using cut_iteration_loop diamond_left_mult diamond_n_n_same by auto

text ‹Theorem 24.1›

lemma cut_iteration_while_loop_2:
  "|xΩ>n(y) = |an(y)  x>n(y)"
  by (metis cut_iteration_while_loop an_uminus n_an_def while_Omega_def)

lemma modal_while:
  assumes "-q * -p * L  x * -p * L  -p  -q  -r"
    shows "-p  |n((-q * x)ω) * L  (-q * x) * --q>(-r)"
proof -
  have 1: "--q * -p  |-q * x>(-p)  --q * -r"
    using assms mult_right_isotone sup.coboundedI2 tests_dual.sup_complement_intro by auto
  have "-q * -p = n(-q * -q * -p * L)"
    using an_uminus n_export_an mult_assoc mult_1_right n_L tests_dual.sup_idempotent by auto
  also have "...  n(-q * x * -p * L)"
    by (metis assms n_isotone mult_right_isotone mult_assoc)
  also have "...  |-q * x>(-p)  --q * -r"
    by (simp add: ndiamond_def)
  finally have "-p  |-q * x>(-p)  --q * -r"
    using 1 by (smt sup_assoc le_iff_sup tests_dual.inf_cases sub_comm)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc n_n_L n_omega_mult ndiamond_def sub_mult_closed)
qed

lemma modal_while_loop:
  "-q * -p * L  x * -p * L  -p  -q  -r  -p  |(-q * x)Ω * --q>(-r)"
  by (metis L_left_zero Omega_def modal_while mult_assoc mult_right_dist_sup)

text ‹Theorem 24.2›

lemma modal_while_loop_2:
  "-q * -p * L  x * -p * L  -p  -q  -r  -p  |-q  x>(-r)"
  by (simp add: while_Omega_def modal_while_loop)

lemma modal_while_2:
  assumes "-p * L  x * -p * L"
    shows "-p  |n((-q * x)ω) * L  (-q * x) * --q>(--q)"
proof -
  have "-p  |-q * x>(-p)  --q"
    by (smt (verit, del_insts) assms an_uminus tests_dual.double_negation n_an_def n_isotone ndiamond_def diamond_an_export sup_assoc sup_commute le_iff_sup tests_dual.inf_complement_intro)
  thus ?thesis
    by (smt L_left_zero an_diamond_omega_induct_an an_uminus diamond_left_dist_sup mult_assoc tests_dual.sup_idempotent n_n_L n_omega_mult ndiamond_def)
qed

end

class n_modal_omega_algebra = n_box_omega_algebra +
  assumes n_star_induct: "n(x * y)  n(y)  n(x * y)  n(y)"
begin

lemma n_star_induct_sup:
  "n(z  x * y)  n(y)  n(x * z)  n(y)"
  by (metis an_dist_sup an_mult_least_upper_bound an_n_order n_mult_right_upper_bound n_star_induct star_L_split)

lemma n_star_induct_star:
  "n(x * y)  n(y)  n(x)  n(y)"
  using n_star_induct n_star_mult by auto

lemma n_star_induct_iff:
  "n(x * y)  n(y)  n(x * y)  n(y)"
  by (metis mult_left_isotone n_isotone n_star_induct order_trans star.circ_increasing)

lemma n_star_bot:
  "n(x) = bot  n(x) = bot"
  by (metis sup_bot_right le_iff_sup mult_1_right n_one n_star_induct_iff)

lemma n_diamond_star_induct:
  "|x>n(y)  n(y)  |x>n(y)  n(y)"
  by (simp add: diamond_x_n n_star_induct)

lemma n_diamond_star_induct_sup:
  "|x>n(y)  n(z)  n(y)  |x>n(z)  n(y)"
  by (simp add: diamond_x_n n_dist_sup n_star_induct_sup)

lemma n_diamond_star_induct_iff:
  "|x>n(y)  n(y)  |x>n(y)  n(y)"
  using diamond_x_n n_star_induct_iff by auto

lemma an_star_induct:
  "an(y)  an(x * y)  an(y)  an(x * y)"
  using an_n_order n_star_induct by auto

lemma an_star_induct_sup:
  "an(y)  an(z  x * y)  an(y)  an(x * z)"
  using an_n_order n_star_induct_sup by auto

lemma an_star_induct_star:
  "an(y)  an(x * y)  an(y)  an(x)"
  by (simp add: an_n_order n_star_induct_star)

lemma an_star_induct_iff:
  "an(y)  an(x * y)  an(y)  an(x * y)"
  using an_n_order n_star_induct_iff by auto

lemma an_star_one:
  "an(x) = 1  an(x) = 1"
  by (metis an_n_equal an_bot n_star_bot n_bot)

lemma an_box_star_induct:
  "an(y)  |x]an(y)  an(y)  |x]an(y)"
  by (simp add: an_star_induct box_x_an)

lemma an_box_star_induct_sup:
  "an(y)  |x]an(y) * an(z)  an(y)  |x]an(z)"
  by (simp add: an_star_induct_sup an_dist_sup an_mult_commutative box_x_an)

lemma an_box_star_induct_iff:
  "an(y)  |x]an(y)  an(y)  |x]an(y)"
  using an_star_induct_iff box_x_an by auto

lemma box_star_segerberg_an:
  "|x]an(y) = an(y) * |x](n(y)  |x]an(y))"
proof (rule order.antisym)
  show "|x]an(y)  an(y) * |x](n(y)  |x]an(y))"
    by (smt (verit) sup_ge2 box_1_an box_left_dist_sup box_left_mult box_right_isotone mult_right_isotone star.circ_right_unfold)
next
  have "an(y) * |x](n(y)  |x]an(y))  an(y) * |x]an(y)"
    by (metis sup_bot_left an_complement_bot box_an_an box_left_antitone box_x_an mult_left_dist_sup mult_left_one mult_right_isotone star.circ_reflexive)
  thus "an(y) * |x](n(y)  |x]an(y))  |x]an(y)"
    by (smt an_box_star_induct_sup an_case_split_left an_dist_sup an_mult_least_upper_bound box_left_antitone box_left_mult box_right_mult_an_an star.left_plus_below_circ nbox_def)
qed

lemma box_star_segerberg_n:
  "|x]n(y) = n(y) * |x](an(y)  |x]n(y))"
  using box_star_segerberg_an an_n_def n_an_def by auto

lemma diamond_segerberg_an:
  "|x>an(y) = an(y)  |x>(n(y) * |x>an(y))"
  by (smt an_export an_n_L box_diamond box_star_segerberg_an diamond_box mult_assoc n_an_def)

lemma diamond_star_segerberg_n:
  "|x>n(y) = n(y)  |x>(an(y) * |x>n(y))"
  using an_n_def diamond_segerberg_an n_an_def by auto

lemma box_cut_star_iteration_an:
  "|x]an(y) = |(an(y) * x)]an(y)"
  by (smt an_box_star_induct_sup an_mult_commutative an_mult_complement_intro_an order.antisym box_an_export box_star_unfold_an nbox_def order_refl)

lemma box_cut_star_iteration_n:
  "|x]n(y) = |(n(y) * x)]n(y)"
  using box_cut_star_iteration_an n_an_def by auto

lemma diamond_cut_star_iteration_an:
  "|x>an(y) = |(n(y) * x)>an(y)"
  using box_cut_star_iteration_an diamond_box n_an_def by auto

lemma diamond_cut_star_iteration_n:
  "|x>n(y) = |(an(y) * x)>n(y)"
  using box_cut_star_iteration_an an_n_L diamond_box by auto

lemma ni_star_induct:
  "ni(x * y)  ni(y)  ni(x * y)  ni(y)"
  using n_star_induct ni_n_order by auto

lemma ni_star_induct_sup:
  "ni(z  x * y)  ni(y)  ni(x * z)  ni(y)"
  by (simp add: ni_n_order n_star_induct_sup)

lemma ni_star_induct_star:
  "ni(x * y)  ni(y)  ni(x)  ni(y)"
  using ni_n_order n_star_induct_star by auto

lemma ni_star_induct_iff:
  "ni(x * y)  ni(y)  ni(x * y)  ni(y)"
  using ni_n_order n_star_induct_iff by auto

lemma ni_star_bot:
  "ni(x) = bot  ni(x) = bot"
  using ni_n_bot n_star_bot by auto

lemma ni_diamond_star_induct:
  "x»ni(y)  ni(y)  x»ni(y)  ni(y)"
  by (simp add: diamond_L_x_ni ni_star_induct)

lemma ni_diamond_star_induct_sup:
  "x»ni(y)  ni(z)  ni(y)  x»ni(z)  ni(y)"
  by (simp add: diamond_L_x_ni ni_dist_sup ni_star_induct_sup)

lemma ni_diamond_star_induct_iff:
  "x»ni(y)  ni(y)  x»ni(y)  ni(y)"
  using diamond_L_x_ni ni_star_induct_iff by auto

lemma ani_star_induct:
  "ani(y)  ani(x * y)  ani(y)  ani(x * y)"
  using an_star_induct ani_an_order by blast

lemma ani_star_induct_sup:
  "ani(y)  ani(z  x * y)  ani(y)  ani(x * z)"
  by (simp add: an_star_induct_sup ani_an_order)

lemma ani_star_induct_star:
  "ani(y)  ani(x * y)  ani(y)  ani(x)"
  using an_star_induct_star ani_an_order by auto

lemma ani_star_induct_iff:
  "ani(y)  ani(x * y)  ani(y)  ani(x * y)"
  using an_star_induct_iff ani_an_order by auto

lemma ani_star_L:
  "ani(x) = L  ani(x) = L"
  using an_star_one ani_an_L by auto

lemma ani_box_star_induct:
  "ani(y)  xani(y)  ani(y)  xani(y)"
  by (metis an_ani ani_def ani_star_induct_iff n_ani box_L_ani)

lemma ani_box_star_induct_iff:
  "ani(y)  xani(y)  ani(y)  xani(y)"
  using ani_box_star_induct box_L_left_antitone order_lesseq_imp star.circ_increasing by blast

lemma ani_box_star_induct_sup:
  "ani(y)  xani(y)  ani(y)  ani(z)  ani(y)  xani(z)"
  by (meson ani_box_star_induct_iff box_L_right_isotone order_trans)

end

end

Theory Approximation

(* Title:      Approximation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Approximation›

theory Approximation

imports Stone_Kleene_Relation_Algebras.Iterings

begin

class apx =
  fixes apx :: "'a  'a  bool" (infix "" 50)

class apx_order = apx +
  assumes apx_reflexive: "x  x"
  assumes apx_antisymmetric: "x  y  y  x  x = y"
  assumes apx_transitive: "x  y  y  z  x  z"

sublocale apx_order < apx: order where less_eq = apx and less = "λx y . x  y  ¬ y  x"
  apply unfold_locales
  apply simp
  apply (rule apx_reflexive)
  using apx_transitive apply blast
  by (simp add: apx_antisymmetric)

context apx_order
begin

abbreviation the_apx_least_fixpoint    :: "('a  'a)  'a" ("κ _" [201] 200)  where "κ  f  apx.the_least_fixpoint f"
abbreviation the_apx_least_prefixpoint :: "('a  'a)  'a" (" _" [201] 200) where " f  apx.the_least_prefixpoint f"

definition is_apx_meet  :: "'a  'a  'a  bool"          where "is_apx_meet x y z  z  x  z  y  (w . w  x  w  y  w  z)"
definition has_apx_meet :: "'a  'a  bool"                where "has_apx_meet x y  z . is_apx_meet x y z"
definition the_apx_meet :: "'a  'a  'a" (infixl "" 66) where "x  y  THE z . is_apx_meet x y z"

lemma apx_meet_unique:
  "has_apx_meet x y  ∃!z . is_apx_meet x y z"
  by (meson apx_antisymmetric has_apx_meet_def is_apx_meet_def)

lemma apx_meet:
  assumes "has_apx_meet x y"
    shows "is_apx_meet x y (x  y)"
proof -
  have "is_apx_meet x y (THE z . is_apx_meet x y z)"
    by (metis apx_meet_unique assms theI)
  thus ?thesis
    by (simp add: the_apx_meet_def)
qed

lemma apx_greatest_lower_bound:
  "has_apx_meet x y  (w  x  w  y  w  x  y)"
  by (meson apx_meet apx_transitive is_apx_meet_def)

lemma apx_meet_same:
  "is_apx_meet x y z  z = x  y"
  using apx_meet apx_meet_unique has_apx_meet_def by blast

lemma apx_meet_char:
  "is_apx_meet x y z  has_apx_meet x y  z = x  y"
  using apx_meet_same has_apx_meet_def by auto

end

class apx_biorder = apx_order + order
begin

lemma mu_below_kappa:
  "has_least_fixpoint f  apx.has_least_fixpoint f  μ f  κ f"
  using apx.mu_unfold is_least_fixpoint_def least_fixpoint by auto

lemma kappa_below_nu:
  "has_greatest_fixpoint f  apx.has_least_fixpoint f  κ f  ν f"
  by (meson apx.mu_unfold greatest_fixpoint is_greatest_fixpoint_def)

lemma kappa_apx_below_mu:
  "has_least_fixpoint f  apx.has_least_fixpoint f  κ f  μ f"
  using apx.is_least_fixpoint_def apx.least_fixpoint mu_unfold by auto

lemma kappa_apx_below_nu:
  "has_greatest_fixpoint f  apx.has_least_fixpoint f  κ f  ν f"
  by (metis apx.is_least_fixpoint_def apx.least_fixpoint nu_unfold)

end

class apx_semiring = apx_biorder + idempotent_left_semiring + L +
  assumes apx_L_least: "L  x"
  assumes sup_apx_left_isotone: "x  y  x  z  y  z"
  assumes mult_apx_left_isotone: "x  y  x * z  y * z"
  assumes mult_apx_right_isotone: "x  y  z * x  z * y"
begin

lemma sup_apx_right_isotone:
  "x  y  z  x  z  y"
  by (simp add: sup_apx_left_isotone sup_commute)

lemma sup_apx_isotone:
  "w  y  x  z  w  x  y  z"
  by (meson apx_transitive sup_apx_left_isotone sup_apx_right_isotone)

lemma mult_apx_isotone:
  "w  y  x  z  w * x  y * z"
  by (meson apx_transitive mult_apx_left_isotone mult_apx_right_isotone)

lemma affine_apx_isotone:
  "apx.isotone (λx . y * x  z)"
  by (simp add: apx.isotone_def mult_apx_right_isotone sup_apx_left_isotone)

end

end

Theory Recursion_Strict

(* Title:      Strict Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Strict Recursion›

theory Recursion_Strict

imports N_Semirings Approximation

begin

class semiring_apx = n_semiring + apx +
  assumes apx_def: "x  y  x  y  n(x) * L  y  x  n(x) * top"
begin

lemma apx_n_order_reverse:
  "y  x  n(x)  n(y)"
  by (metis apx_def le_iff_sup n_sup_left_absorb_mult n_dist_sup n_export)

lemma apx_n_order:
  "x  y  y  x  n(x) = n(y)"
  by (simp add: apx_n_order_reverse order.antisym)

lemma apx_transitive:
  assumes "x  y"
      and "y  z"
    shows "x  z"
proof -
  have "n(y) * L  n(x) * L"
    by (simp add: apx_n_order_reverse assms(1) mult_left_isotone)
  hence 1: "x  z  n(x) * L"
    by (smt assms sup_assoc sup_right_divisibility apx_def le_iff_sup)
  have "z  x  n(x) * top  n(x  n(x) * top) * top"
    by (smt (verit) assms sup_left_isotone order_refl sup_assoc sup_mono apx_def mult_left_isotone n_isotone order_trans)
  also have "... = x  n(x) * top"
    by (simp add: n_dist_sup n_export n_sup_left_absorb_mult)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text ‹Theorem 16.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def)
  apply (smt (verit) order.antisym le_sup_iff apx_def eq_refl le_iff_sup n_galois apx_n_order)
  using apx_transitive by blast

lemma sup_apx_left_isotone:
  assumes "x  y"
    shows "x  z  y  z"
proof -
  have "x  y  n(x) * L  y  x  n(x) * top"
    using assms apx_def by auto
  hence "z  x  z  y  n(z  x) * L  z  y  z  x  n(z  x) * top"
    by (metis sup_assoc sup_right_isotone mult_right_sub_dist_sup_right n_dist_sup order_trans)
  thus ?thesis
    by (simp add: apx_def sup_commute)
qed

lemma mult_apx_left_isotone:
  assumes "x  y"
    shows "x * z  y * z"
proof -
  have "x  y  n(x) * L"
    using assms apx_def by auto
  hence "x * z  y * z  n(x) * L"
    by (smt (verit, ccfv_threshold) L_left_zero mult_left_isotone semiring.distrib_right mult_assoc)
  hence 1: "x * z  y * z  n(x * z) * L"
    by (meson mult_left_isotone n_mult_left_upper_bound order_lesseq_imp sup_mono)
  have "y * z  x * z  n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence "y * z  x * z  n(x * z) * top"
    using mult_isotone n_mult_left_upper_bound order.trans sup_right_isotone top_greatest mult_assoc by presburger
  thus ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone:
  assumes "x  y"
    shows "z * x  z * y"
proof -
  have "x  y  n(x) * L"
    using assms apx_def by auto
  hence 1: "z * x  z * y  n(z * x) * L"
    by (smt sup_assoc sup_ge1 sup_bot_right mult_assoc mult_left_dist_sup mult_right_isotone n_L_split)
  have "y  x  n(x) * top"
    using assms apx_def by auto
  hence "z * y  z * x  z * n(x) * top"
    by (smt mult_assoc mult_left_dist_sup mult_right_isotone)
  also have "...  z * x  n(z * x) * top"
    by (smt (verit) sup_assoc le_supI le_sup_iff sup_ge1 sup_bot_right mult_left_dist_sup n_L_split n_top_split order_trans)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text ‹Theorem 16.1 and Theorem 16.2›

subclass apx_semiring
  apply unfold_locales
  apply (metis sup_right_top sup_ge2 apx_def mult_left_one n_L top_greatest)
  apply (simp add: sup_apx_left_isotone)
  apply (simp add: mult_apx_left_isotone)
  by (simp add: mult_apx_right_isotone)

text ‹Theorem 16.2›

lemma ni_apx_isotone:
  "x  y  ni(x)  ni(y)"
  using apx_n_order_reverse apx_def le_supI1 n_ni ni_def ni_n_order by force

text ‹Theorem 17›

definition kappa_apx_meet :: "('a  'a)  bool"
  where "kappa_apx_meet f  apx.has_least_fixpoint f  has_apx_meet (μ f) (ν f)  κ f = μ f  ν f"

definition kappa_mu_nu :: "('a  'a)  bool"
  where "kappa_mu_nu f  apx.has_least_fixpoint f  κ f = μ f  n(ν f) * L"

definition nu_below_mu_nu :: "('a  'a)  bool"
  where "nu_below_mu_nu f  ν f  μ f  n(ν f) * top"

definition mu_nu_apx_nu :: "('a  'a)  bool"
  where "mu_nu_apx_nu f  μ f  n(ν f) * L  ν f"

definition mu_nu_apx_meet :: "('a  'a)  bool"
  where "mu_nu_apx_meet f  has_apx_meet (μ f) (ν f)  μ f  ν f = μ f  n(ν f) * L"

definition apx_meet_below_nu :: "('a  'a)  bool"
  where "apx_meet_below_nu f  has_apx_meet (μ f) (ν f)  μ f  ν f  ν f"

lemma mu_below_l:
  "μ f  μ f  n(ν f) * L"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  μ f  n(ν f) * L  ν f"
  by (simp add: mu_below_nu n_L_decreasing)

lemma n_l_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  n(μ f  n(ν f) * L) = n(ν f)"
  by (metis le_iff_sup mu_below_nu n_dist_sup n_n_L)

lemma l_apx_mu:
  "has_least_fixpoint f  has_greatest_fixpoint f  μ f  n(ν f) * L  μ f"
  by (simp add: apx_def le_supI1 n_l_nu)

text ‹Theorem 17.4 implies Theorem 17.5›

lemma nu_below_mu_nu_mu_nu_apx_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  nu_below_mu_nu f  mu_nu_apx_nu f"
  by (smt (z3) l_below_nu apx_def le_sup_iff sup.absorb2 sup_commute sup_monoid.add_assoc mu_nu_apx_nu_def n_l_nu nu_below_mu_nu_def)

text ‹Theorem 17.5 implies Theorem 17.6›

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f  n(ν f) * L"
  have "is_apx_meet (μ f) (ν f) ?l"
    apply (unfold is_apx_meet_def, intro conjI)
    apply (simp add: assms(1,2) l_apx_mu)
    using assms(3) mu_nu_apx_nu_def apply blast
    by (meson assms(1,2) l_below_nu apx_def order_trans sup_ge1 sup_left_isotone)
  thus ?thesis
    by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed

text ‹Theorem 17.6 implies Theorem 17.7›

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  mu_nu_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

text ‹Theorem 17.7 implies Theorem 17.4›

lemma apx_meet_below_nu_nu_below_mu_nu:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu f"
proof -
  have "m . m  μ f  m  ν f  m  ν f  ν f  μ f  n(m) * top"
    by (smt (verit) sup_assoc sup_left_isotone sup_right_top apx_def mult_left_dist_sup order_trans)
  thus ?thesis
    by (smt (verit) assms sup_right_isotone apx_greatest_lower_bound apx_meet_below_nu_def apx_reflexive mult_left_isotone n_isotone nu_below_mu_nu_def order_trans)
qed

text ‹Theorem 17.1 implies Theorem 17.2›

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have "w . w  μ f  w  ν f  w  κ f"
    by (meson assms apx_def order.trans kappa_below_nu mu_below_kappa semiring.add_right_mono)
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

text ‹Theorem 17.2 implies Theorem 17.7›

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f  kappa_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

text ‹Theorem 17.7 implies Theorem 17.3›

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f  n(ν f) * L"
  let ?m = "μ f  ν f"
  have 1: "?l  ν f"
    using apx_meet_below_nu_nu_below_mu_nu assms(1,2,5) mu_nu_apx_nu_def nu_below_mu_nu_mu_nu_apx_nu by blast
  hence 2: "?m = ?l"
    using assms(1,2) mu_nu_apx_meet_def mu_nu_apx_nu_def mu_nu_apx_nu_mu_nu_apx_meet by blast
  have "μ f  f(?l)"
    by (metis assms(1,3) isotone_def mu_unfold sup_ge1)
  hence 3: "?l  f(?l)  n(?l) * L"
    using assms(1,2) semiring.add_right_mono n_l_nu by auto
  have "f(?l)  f(ν f)"
    using assms(1-3) l_below_nu isotone_def by blast
  also have "...  ?l  n(?l) * top"
    using 1 by (metis assms(2) apx_def nu_unfold)
  finally have 4: "?l  f(?l)"
    using 3 apx_def by blast
  have 5: "f(?l)  μ f"
    by (metis assms(1,2,4) apx.isotone_def is_least_fixpoint_def least_fixpoint l_apx_mu)
  have "f(?l)  ν f"
    using 1 by (metis assms(2,4) apx.isotone_def greatest_fixpoint is_greatest_fixpoint_def)
  hence "f(?l)  ?l"
    using 2 5 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
  hence "f(?l) = ?l"
    using 4 by (simp add: apx.order.antisym)
  thus ?thesis
    using 1 by (smt (verit, del_insts) assms(1,2) sup_left_isotone apx_antisymmetric apx_def apx.least_fixpoint_char greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def is_least_fixpoint_def least_fixpoint n_l_nu order_trans kappa_mu_nu_def)
qed

text ‹Theorem 17.3 implies Theorem 17.1›

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f  apx.has_least_fixpoint f"
  using kappa_mu_nu_def by auto

text ‹Theorem 17.4 implies Theorem 17.3›

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu f  kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_mu_nu_apx_nu by blast

text ‹Theorem 17.3 implies Theorem 17.4›

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu f  nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)

definition kappa_mu_nu_ni :: "('a  'a)  bool"
  where "kappa_mu_nu_ni f  apx.has_least_fixpoint f  κ f = μ f  ni(ν f)"

lemma kappa_mu_nu_ni_kappa_mu_nu:
  "kappa_mu_nu_ni f  kappa_mu_nu f"
  by (simp add: kappa_mu_nu_def kappa_mu_nu_ni_def ni_def)

lemma nu_below_mu_nu_kappa_mu_nu_ni:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu f  kappa_mu_nu_ni f"
  by (simp add: kappa_mu_nu_ni_kappa_mu_nu nu_below_mu_nu_kappa_mu_nu)

lemma kappa_mu_nu_ni_nu_below_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu_ni f  nu_below_mu_nu f"
  using kappa_mu_nu_ni_kappa_mu_nu kappa_mu_nu_nu_below_mu_nu by blast

end

class itering_apx = n_itering + semiring_apx
begin

text ‹Theorem 16.3›

lemma circ_apx_isotone:
  assumes "x  y"
    shows "x  y"
proof -
  have 1: "x  y  n(x) * L  y  x  n(x) * top"
    using assms apx_def by auto
  hence "y  x  x * n(x) * top"
    by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "...  x  n(x * x) * top"
    by (smt le_sup_iff n_isotone n_top_split order_refl order_trans right_plus_below_circ zero_right_mult_decreasing)
  also have "...  x  n(x) * top"
    by (simp add: circ_plus_same n_circ_left_unfold)
  finally have 2: "y  x  n(x) * top"
    .
  have "x  y  y * n(x) * L"
    using 1 by (metis L_left_zero circ_isotone circ_unfold_sum mult_assoc)
  also have "... = y  n(y * x) * L"
    by (metis sup_assoc sup_bot_right mult_assoc mult_zero_sup_circ_2 n_L_split n_mult_right_bot)
  also have "...  y  n(x * x) * L  n(x) * n(top * x) * L"
    using 2 by (metis sup_assoc sup_right_isotone mult_assoc mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone)
  finally have "x  y  n(x) * L"
    by (metis sup_assoc circ_plus_same n_sup_left_absorb_mult n_circ_left_unfold n_dist_sup n_export ni_def ni_dist_sup)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx = n_omega_algebra_2 + semiring_apx

sublocale omega_algebra_apx < star: itering_apx where circ = star ..

sublocale omega_algebra_apx < nL_omega: itering_apx where circ = Omega ..

context omega_algebra_apx
begin

text ‹Theorem 16.4›

lemma omega_apx_isotone:
  assumes "x  y"
    shows "xω  yω"
proof -
  have 1: "x  y  n(x) * L  y  x  n(x) * top"
    using assms apx_def by auto
  hence "yω  x * n(x) * top * (x * n(x) * top)ω  xω  x * n(x) * top * (x * n(x) * top) * xω"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "...  x * n(x) * top  xω  x * n(x) * top * (x * n(x) * top) * xω"
    using mult_top_omega omega_unfold sup_left_isotone by auto
  also have "... = x * n(x) * top  xω"
    by (smt (z3) mult_left_dist_sup sup_assoc sup_commute sup_left_top mult_assoc)
  also have "...  n(x * x) * top  x * bot  xω"
    using n_top_split semiring.add_left_mono sup_commute by fastforce
  also have "...  n(x * x) * top  xω"
    using semiring.add_right_mono star_bot_below_omega sup_commute by fastforce
  finally have 2: "yω  xω  n(xω) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_star_below_n_omega n_star_left_unfold order_trans star.circ_plus_same)
  have "xω  (y  n(x) * L)ω"
    using 1 by (simp add: omega_isotone)
  also have "... = y * n(x) * L * (y * n(x) * L)ω  yω  y * n(x) * L * (y * n(x) * L) * yω"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "... = y * n(x) * L  yω"
    using L_left_zero sup_assoc sup_monoid.add_commute mult_assoc by force
  also have "...  yω  y * bot  n(y * x) * L"
    by (simp add: n_L_split sup_assoc sup_commute)
  also have "...  yω  n(x * x) * L  n(x) * n(top * x) * L"
    using 1 by (metis sup_right_isotone sup_bot_right apx_def mult_assoc mult_left_dist_sup mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone star.circ_apx_isotone star_mult_omega sup_assoc)
  finally have "xω  yω  n(xω) * L"
    by (smt (verit, best) le_supE sup.orderE sup_commute sup_assoc sup_isotone mult_right_dist_sup n_sup_left_absorb_mult n_star_left_unfold ni_def ni_star_below_ni_omega order_refl order_trans star.circ_plus_same)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx_extra = omega_algebra_apx +
  assumes n_split_omega: "xω  x * bot  n(xω) * top"
begin

lemma omega_n_star:
  "xω  n(x) * top  x * n(xω) * top"
proof -
  have 1: "n(x) * top  n(xω) * top"
    by (simp add: mult_left_isotone n_star_below_n_omega)
  have "...  x * n(xω) * top"
    by (simp add: star_n_omega_top)
  thus ?thesis
    using 1 by (metis le_sup_iff n_split_omega order_trans star_n_omega_top)
qed

lemma n_omega_zero:
  "n(xω) = bot  n(x) = bot  xω  x * bot"
  by (metis sup_bot_right order.eq_iff mult_left_zero n_mult_bot n_split_omega star_bot_below_omega)

lemma n_split_nu_mu:
  "yω  y * z  y * z  n(yω  y * z) * top"
proof -
  have "yω  y * bot  n(yω  y * z) * top"
    by (smt sup_ge1 sup_right_isotone mult_left_isotone n_isotone n_split_omega order_trans)
  also have "...  y * z  n(yω  y * z) * top"
    using nL_star.star_zero_below_circ_mult sup_left_isotone by auto
  finally show ?thesis
    by simp
qed

lemma loop_exists:
  "ν (λx . y * x  z)  μ (λx . y * x  z)  n(ν (λx . y * x  z)) * top"
  by (metis n_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x  z) (μ (λx . y * x  z)  n(ν (λx . y * x  z)) * L)"
  using apx.least_fixpoint_char affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x  z)"
  using affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_semantics:
  "κ (λx . y * x  z) = μ (λx . y * x  z)  n(ν (λx . y * x  z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by auto

lemma loop_apx_least_fixpoint_ni:
  "apx.is_least_fixpoint (λx . y * x  z) (μ (λx . y * x  z)  ni(ν (λx . y * x  z)))"
  using ni_def loop_apx_least_fixpoint by auto

lemma loop_semantics_ni:
  "κ (λx . y * x  z) = μ (λx . y * x  z)  ni(ν (λx . y * x  z))"
  using ni_def loop_semantics by auto

text ‹Theorem 18›

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x  z) = n(yω) * L  y * z"
proof -
  have "κ (λx . y * x  z) = y * z  n(yω  y * z) * L"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (smt sup_assoc sup_commute le_iff_sup mult_right_dist_sup n_L_decreasing n_dist_sup)
qed

end

class omega_algebra_apx_extra_2 = omega_algebra_apx +
  assumes omega_n_star: "xω  x * n(xω) * top"
begin

subclass omega_algebra_apx_extra
  apply unfold_locales
  using omega_n_star star_n_omega_top by auto

end

end

Theory N_Algebras

(* Title:      N-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Algebras›

theory N_Algebras

imports Stone_Kleene_Relation_Algebras.Iterings Base Lattice_Ordered_Semirings

begin

class C_left_n_algebra = bounded_idempotent_left_semiring + bounded_distrib_lattice + n + L
begin

abbreviation C :: "'a  'a" where "C x  n(L) * top  x"

text ‹AACP Theorem 3.38›

lemma C_isotone:
  "x  y  C x  C y"
  using inf.sup_right_isotone by auto

text ‹AACP Theorem 3.40›

lemma C_decreasing:
  "C x  x"
  by simp

end

class left_n_algebra = C_left_n_algebra +
  assumes n_dist_n_add            : "n(x)  n(y) = n(n(x) * top  y)"
  assumes n_export                : "n(x) * n(y) = n(n(x) * y)"
  assumes n_left_upper_bound      : "n(x)  n(x  y)"
  assumes n_nL_meet_L_nL0         : "n(L) * x = (x  L)  n(L * bot) * x"
  assumes n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot  n(x * n(y) * L) * L"
  assumes n_sub_nL                : "n(x)  n(L)"
  assumes n_L_decreasing          : "n(x) * L  x"
  assumes n_L_T_meet_mult_combined: "C (x * y) * z  C x * y * C z"
  assumes n_n_top_split_n_top     : "x * n(y) * top  x * bot  n(x * y) * top"
  assumes n_top_meet_L_below_L    : "x * top * y  L  x * L * y"
begin

subclass lattice_ordered_pre_left_semiring ..

lemma n_L_T_meet_mult_below:
  "C (x * y)  C x * y"
proof -
  have "C (x * y)  C x * y * C 1"
    by (meson order.trans mult_sub_right_one n_L_T_meet_mult_combined)
  also have "...  C x * y"
    by (metis mult_1_right mult_left_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.41›

lemma n_L_T_meet_mult_propagate:
  "C x * y  x * C y"
proof -
  have "C x * y  C x * 1 * C y"
    by (metis mult_1_right mult_assoc n_L_T_meet_mult_combined mult_1_right)
  also have "...  x * C y"
    by (simp add: mult_right_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.43›

lemma C_n_mult_closed:
  "C (n(x) * y) = n(x) * y"
  by (simp add: inf.absorb2 mult_isotone n_sub_nL)

text ‹AACP Theorem 3.40›

lemma meet_L_below_C:
  "x  L  C x"
  by (simp add: le_supI1 n_nL_meet_L_nL0)

text ‹AACP Theorem 3.42›

lemma n_L_T_meet_mult:
  "C (x * y) = C x * y"
  apply (rule order.antisym)
  apply (rule n_L_T_meet_mult_below)
  by (smt (z3) C_n_mult_closed inf.boundedE inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_right_sub_dist_inf mult_assoc)

text ‹AACP Theorem 3.42›

lemma C_mult_propagate:
  "C x * y = C x * C y"
  by (smt (z3) C_n_mult_closed order.eq_iff inf.left_commute inf.sup_monoid.add_commute mult_left_sub_dist_inf_right n_L_T_meet_mult_propagate)

text ‹AACP Theorem 3.32›

lemma meet_L_below_n_L:
  "x  L  n(L) * x"
  by (simp add: n_nL_meet_L_nL0)

text ‹AACP Theorem 3.27›

lemma n_vector_meet_L:
  "x * top  L  x * L"
  by (metis mult_1_right n_top_meet_L_below_L)

lemma n_right_upper_bound:
  "n(x)  n(y  x)"
  by (simp add: n_left_upper_bound sup_commute)

text ‹AACP Theorem 3.1›

lemma n_isotone:
  "x  y  n(x)  n(y)"
  by (metis le_iff_sup n_left_upper_bound)

lemma n_add_left_zero:
  "n(bot)  n(x) = n(x)"
  using le_iff_sup sup_bot_right sup_right_divisibility n_isotone by auto

text ‹AACP Theorem 3.13›

lemma n_mult_right_zero_L:
  "n(x) * bot  L"
  by (meson bot_least mult_isotone n_L_decreasing n_sub_nL order_trans)

lemma n_add_left_top:
  "n(top)  n(x) = n(top)"
  by (simp add: sup_absorb1 n_isotone)

text ‹AACP Theorem 3.18›

lemma n_n_L:
  "n(n(x) * L) = n(x)"
  by (metis order.antisym n_dist_n_add n_export n_sub_nL sup_bot_right sup_commute sup_top_left n_add_left_zero n_right_upper_bound)

lemma n_mult_transitive:
  "n(x) * n(x)  n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

lemma n_mult_left_absorb_add_sub:
  "n(x) * (n(x)  n(y))  n(x)"
  by (metis mult_right_isotone n_dist_n_add n_export n_sub_nL n_n_L)

text ‹AACP Theorem 3.21›

lemma n_mult_left_lower_bound:
  "n(x) * n(y)  n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

text ‹AACP Theorem 3.20›

lemma n_mult_left_zero:
  "n(bot) * n(x) = n(bot)"
  by (metis n_export sup_absorb1 n_add_left_zero n_mult_left_lower_bound)

lemma n_mult_right_one:
  "n(x) * n(top) = n(x)"
  using n_dist_n_add n_export sup_commute n_add_left_zero by fastforce

lemma n_L_increasing:
  "n(x)  n(n(x) * L)"
  by (simp add: n_n_L)

text ‹AACP Theorem 3.2›

lemma n_galois:
  "n(x)  n(y)  n(x) * L  y"
  by (metis mult_left_isotone n_L_decreasing n_L_increasing n_isotone order_trans)

lemma n_add_n_top:
  "n(x  n(x) * top) = n(x)"
  by (metis n_dist_n_add sup.idem sup_commute)

text ‹AACP Theorem 3.6›

lemma n_L_below_nL_top:
  "L  n(L) * top"
  by (metis inf_top.left_neutral meet_L_below_n_L)

text ‹AACP Theorem 3.4›

lemma n_less_eq_char_n:
  "x  y  x  y  L  C x  y  n(y) * top"
proof
  assume "x  y"
  thus "x  y  L  C x  y  n(y) * top"
    by (simp add: inf.coboundedI2 le_supI1)
next
  assume 1: "x  y  L  C x  y  n(y) * top"
  hence "x  y  (x  L)"
    using sup_commute sup_inf_distrib2 by force
  also have "...  y  C x"
    using sup_right_isotone meet_L_below_C by blast
  also have "...  y  n(y) * top"
    using 1 by simp
  finally have "x  y  (L  n(y) * top)"
    using 1 by (simp add: sup_inf_distrib1)
  thus "x  y"
    by (metis inf_commute n_L_decreasing order_trans sup_absorb1 n_vector_meet_L)
qed

text ‹AACP Theorem 3.31›

lemma n_L_decreasing_meet_L:
  "n(x) * L  x  L"
  using n_sub_nL n_galois by auto

text ‹AACP Theorem 3.5›

lemma n_zero_L_zero:
  "n(bot) * L = bot"
  by (simp add: le_bot n_L_decreasing)

lemma n_L_top_below_L:
  "L * top  L"
proof -
  have "n(L * bot) * L * top  L * bot"
    by (metis dense_top_closed mult_isotone n_L_decreasing zero_vector mult_assoc)
  hence "n(L * bot) * L * top  L"
    using order_lesseq_imp zero_right_mult_decreasing by blast
  hence "n(L) * L * top  L"
    by (metis inf.absorb2 n_nL_meet_L_nL0 order.refl sup.absorb_iff1 top_right_mult_increasing mult_assoc)
  thus "L * top  L"
    by (metis inf.absorb2 inf.sup_monoid.add_commute n_L_decreasing n_L_below_nL_top n_vector_meet_L)
qed

text ‹AACP Theorem 3.9›

lemma n_L_top_L:
  "L * top = L"
  by (simp add: order.antisym top_right_mult_increasing n_L_top_below_L)

text ‹AACP Theorem 3.10›

lemma n_L_below_L:
  "L * x  L"
  by (metis mult_right_isotone top.extremum n_L_top_L)

text ‹AACP Theorem 3.7›

lemma n_nL_nT:
  "n(L) = n(top)"
  using order.eq_iff n_sub_nL n_add_left_top by auto

text ‹AACP Theorem 3.8›

lemma n_L_L:
  "n(L) * L = L"
  using order.antisym meet_L_below_n_L n_L_decreasing_meet_L by fastforce

lemma n_top_L:
  "n(top) * L = L"
  using n_L_L n_nL_nT by auto

text ‹AACP Theorem 3.23›

lemma n_n_L_split_n_L:
  "x * n(y) * L  x * bot  n(x * y) * L"
  by (metis n_n_L_split_n_n_L_L n_L_decreasing mult_assoc mult_left_isotone mult_right_isotone n_isotone sup_right_isotone)

text ‹AACP Theorem 3.12›

lemma n_L_split_n_L_L:
  "x * L = x * bot  n(x * L) * L"
  apply (rule order.antisym)
  apply (metis mult_assoc n_n_L_split_n_L n_L_L)
  by (simp add: mult_right_isotone n_L_decreasing)

text ‹AACP Theorem 3.11›

lemma n_L_split_L:
  "x * L  x * bot  L"
  by (metis n_n_L_split_n_n_L_L n_sub_nL sup_right_isotone mult_assoc n_L_L n_galois)

text ‹AACP Theorem 3.24›

lemma n_split_top:
  "x * n(y) * top  x * y  n(x * y) * top"
proof -
  have "x * bot  n(x * y) * top  x * y  n(x * y) * top"
    by (meson bot_least mult_isotone order.refl sup_left_isotone)
  thus ?thesis
    using order.trans n_n_top_split_n_top by blast
qed

text ‹AACP Theorem 3.9›

lemma n_L_L_L:
  "L * L = L"
  by (metis inf.sup_monoid.add_commute inf_absorb1 n_L_below_L n_L_top_L n_vector_meet_L)

text ‹AACP Theorem 3.9›

lemma n_L_top_L_L:
  "L * top * L = L"
  by (simp add: n_L_L_L n_L_top_L)

text ‹AACP Theorem 3.19›

lemma n_n_nL:
  "n(x) = n(x) * n(L)"
  by (simp add: n_export n_n_L)

lemma n_L_mult_idempotent:
  "n(L) * n(L) = n(L)"
  using n_n_nL by auto

text ‹AACP Theorem 3.22›

lemma n_n_L_n:
  "n(x * n(y) * L)  n(x * y)"
  by (simp add: mult_right_isotone n_L_decreasing mult_assoc n_isotone)

text ‹AACP Theorem 3.3›

lemma n_less_eq_char:
  "x  y  x  y  L  x  y  n(y) * top"
  by (meson inf.coboundedI2 le_supI1 n_less_eq_char_n)

text ‹AACP Theorem 3.28›

lemma n_top_meet_L_split_L:
  "x * top * y  L  x * bot  L * y"
proof -
  have "x * top * y  L  x * bot  n(x * L) * L * y"
    by (smt n_top_meet_L_below_L mult_assoc n_L_L_L n_L_split_n_L_L mult_right_dist_sup mult_left_zero)
  also have "...  x * bot  x * L * y"
    using mult_left_isotone n_L_decreasing sup_right_isotone by force
  also have "...  x * bot  (x * bot  L) * y"
    using mult_left_isotone sup_right_isotone n_L_split_L by blast
  also have "... = x * bot  x * bot * y  L * y"
    by (simp add: mult_right_dist_sup sup_assoc)
  also have "... = x * bot  L * y"
    by (simp add: mult_assoc)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.29›

lemma n_top_meet_L_L_meet_L:
  "x * top * y  L = x * L * y  L"
  apply (rule order.antisym)
  apply (simp add: n_top_meet_L_below_L)
  by (metis inf.sup_monoid.add_commute inf.sup_right_isotone mult_isotone order.refl top.extremum)

lemma n_n_top_below_n_L:
  "n(x * top)  n(x * L)"
  by (meson order.trans n_L_decreasing_meet_L n_galois n_vector_meet_L)

text ‹AACP Theorem 3.14›

lemma n_n_top_n_L:
  "n(x * top) = n(x * L)"
  by (metis order.antisym mult_right_isotone n_isotone n_n_top_below_n_L top_greatest)

text ‹AACP Theorem 3.30›

lemma n_meet_L_0_below_0_meet_L:
  "(x  L) * bot  x * bot  L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

text ‹AACP Theorem 3.15›

lemma n_n_L_below_L:
  "n(x) * L  x * L"
  by (metis mult_assoc mult_left_isotone n_L_L_L n_L_decreasing)

lemma n_n_L_below_n_L_L:
  "n(x) * L  n(x * L) * L"
  by (simp add: mult_left_isotone n_galois n_n_L_below_L)

text ‹AACP Theorem 3.16›

lemma n_below_n_L:
  "n(x)  n(x * L)"
  by (simp add: n_galois n_n_L_below_L)

text ‹AACP Theorem 3.17›

lemma n_below_n_L_mult:
  "n(x)  n(L) * n(x)"
  by (metis n_export order_trans meet_L_below_n_L n_L_decreasing_meet_L n_isotone n_n_L)

text ‹AACP Theorem 3.33›

lemma n_meet_L_below:
  "n(x)  L  x"
  by (meson inf.coboundedI1 inf.coboundedI2 le_supI2 sup.cobounded1 top_right_mult_increasing n_less_eq_char)

text ‹AACP Theorem 3.35›

lemma n_meet_L_top_below_n_L:
  "(n(x)  L) * top  n(x) * L"
proof -
  have "(n(x)  L) * top  n(x) * top  L * top"
    by (meson mult_right_sub_dist_inf)
  thus ?thesis
    by (metis n_L_top_L n_vector_meet_L order_trans)
qed

text ‹AACP Theorem 3.34›

lemma n_meet_L_top_below:
  "(n(x)  L) * top  x"
  using order.trans n_L_decreasing n_meet_L_top_below_n_L by blast

text ‹AACP Theorem 3.36›

lemma n_n_meet_L:
  "n(x) = n(x  L)"
  by (meson order.antisym inf.cobounded1 n_L_decreasing_meet_L n_galois n_isotone)

lemma n_T_below_n_meet:
  "n(x) * top = n(C x) * top"
  by (metis inf.absorb2 inf.sup_monoid.add_assoc meet_L_below_C n_n_meet_L)

text ‹AACP Theorem 3.44›

lemma n_C:
  "n(C x) = n(x)"
  by (metis n_T_below_n_meet n_export n_mult_right_one)

text ‹AACP Theorem 3.37›

lemma n_T_meet_L:
  "n(x) * top  L = n(x) * L"
  by (metis antisym_conv n_L_decreasing_meet_L n_n_L n_n_top_n_L n_vector_meet_L)

text ‹AACP Theorem 3.39›

lemma n_L_top_meet_L:
  "C L = L"
  by (simp add: n_L_L n_T_meet_L)

end

class n_algebra = left_n_algebra + idempotent_left_zero_semiring
begin

(* independence of axioms, checked in n_algebra without the respective axiom:
  lemma n_dist_n_add            : "n(x) ⊔ n(y) = n(n(x) * top ⊔ y)" nitpick [expect=genuine,card=5] oops
  lemma n_export                : "n(x) * n(y) = n(n(x) * y)" nitpick [expect=genuine,card=4] oops
  lemma n_left_upper_bound      : "n(x) ≤ n(x ⊔ y)" nitpick [expect=genuine,card=5] oops
  lemma n_nL_meet_L_nL0         : "n(L) * x = (x ⊓ L) ⊔ n(L * bot) * x" nitpick [expect=genuine,card=2] oops
  lemma n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot ⊔ n(x * n(y) * L) * L" nitpick [expect=genuine,card=6] oops
  lemma n_sub_nL                : "n(x) ≤ n(L)" nitpick [expect=genuine,card=2] oops
  lemma n_L_decreasing          : "n(x) * L ≤ x" nitpick [expect=genuine,card=3] oops
  lemma n_L_T_meet_mult_combined: "C (x * y) * z ≤ C x * y * C z" nitpick [expect=genuine,card=4] oops
  lemma n_n_top_split_n_top     : "x * n(y) * top ≤ x * bot ⊔ n(x * y) * top" nitpick [expect=genuine,card=4] oops
  lemma n_top_meet_L_below_L    : "x * top * y ⊓ L ≤ x * L * y" nitpick [expect=genuine,card=5] oops
*)

text ‹AACP Theorem 3.25›

lemma n_top_split_0:
  "n(x) * top * y  x * y  n(x * bot) * top"
proof -
  have 1: "n(x) * top * y  L  x * y"
    using inf.coboundedI1 mult_left_isotone n_L_decreasing_meet_L n_top_meet_L_L_meet_L by force
  have "n(x) * top * y = n(x) * n(L) * top * y"
    using n_n_nL by auto
  also have "... = n(x) * ((top * y  L)  n(L * bot) * top * y)"
    by (metis mult_assoc n_nL_meet_L_nL0)
  also have "...  n(x) * (top * y  L)  n(x) * n(L * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone top_greatest)
  also have "...  (n(x) * top * y  L)  n(n(x) * L * bot) * top"
    by (smt sup_left_isotone order.trans inf_greatest mult_assoc mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right n_export n_galois n_sub_nL)
  also have "...  x * y  n(n(x) * L * bot) * top"
    using 1 sup_left_isotone by blast
  also have "...  x * y  n(x * bot) * top"
    using mult_left_isotone n_galois n_isotone order.refl sup_right_isotone by auto
  finally show ?thesis
    .
qed

text ‹AACP Theorem 3.26›

lemma n_top_split:
  "n(x) * top * y  x * y  n(x * y) * top"
  by (metis order.trans sup_bot_right mult_assoc sup_right_isotone mult_left_isotone mult_left_sub_dist_sup_right n_isotone n_top_split_0)

(*
lemma n_zero: "n(bot) = bot" nitpick [expect=genuine,card=2] oops
lemma n_one: "n(1) = bot" nitpick [expect=genuine,card=2] oops
lemma n_nL_one: "n(L) = 1" nitpick [expect=genuine,card=2] oops
lemma n_nT_one: "n(top) = 1" nitpick [expect=genuine,card=2] oops
lemma n_n_zero: "n(x) = n(x * bot)" nitpick [expect=genuine,card=2] oops
lemma n_dist_add: "n(x) ⊔ n(y) = n(x ⊔ y)" nitpick [expect=genuine,card=4] oops
lemma n_L_split: "x * n(y) * L = x * bot ⊔ n(x * y) * L" nitpick [expect=genuine,card=3] oops
lemma n_split: "x ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_mult_top_1: "n(x * y) ≤ n(x * n(y) * top)" nitpick [expect=genuine,card=3] oops
lemma l91_1: "n(L) * x ≤ n(x * top) * top" nitpick [expect=genuine,card=3] oops
lemma meet_domain_top: "x ⊓ n(y) * top = n(y) * x" nitpick [expect=genuine,card=3] oops
lemma meet_domain_2: "x ⊓ n(y) * top ≤ n(L) * x" nitpick [expect=genuine,card=4] oops
lemma n_nL_top_n_top_meet_L_top_2: "n(L) * x * top ≤ n(x * top ⊓ L) * top" nitpick [expect=genuine,card=3] oops
lemma n_nL_top_n_top_meet_L_top_1: "n(x * top ⊓ L) * top ≤ n(L) * x * top" nitpick [expect=genuine,card=2] oops
lemma l9: "x * bot ⊓ L ≤ n(x * L) * L" nitpick [expect=genuine,card=4] oops
lemma l18_2: "n(x * L) * L ≤ n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l51_1: "n(x) * L ≤ (x ⊓ L) * bot" nitpick [expect=genuine,card=2] oops
lemma l51_2: "(x ⊓ L) * bot ≤ n(x) * L" nitpick [expect=genuine,card=4] oops

lemma n_split_equal: "x ⊔ n(x * L) * top = x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_split_top: "x * top ≤ x * bot ⊔ n(x * L) * top" nitpick [expect=genuine,card=2] oops
lemma n_mult: "n(x * n(y) * L) = n(x * y)" nitpick [expect=genuine,card=3] oops
lemma n_mult_1: "n(x * y) ≤ n(x * n(y) * L)" nitpick [expect=genuine,card=3] oops
lemma n_mult_top: "n(x * n(y) * top) = n(x * y)" nitpick [expect=genuine,card=3] oops
lemma n_mult_right_upper_bound: "n(x * y) ≤ n(z) ⟷ n(x) ≤ n(z) ∧ x * n(y) * L ≤ x * bot ⊔ n(z) * L" nitpick [expect=genuine,card=2] oops
lemma meet_domain: "x ⊓ n(y) * z = n(y) * (x ⊓ z)" nitpick [expect=genuine,card=3] oops
lemma meet_domain_1: "x ⊓ n(y) * z ≤ n(y) * x" nitpick [expect=genuine,card=3] oops
lemma meet_domain_top_3: "x ⊓ n(y) * top ≤ n(y) * x" nitpick [expect=genuine,card=3] oops
lemma n_n_top_n_top_split_n_n_top_top: "n(x) * top ⊔ x * n(y) * top = x * bot ⊔ n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
lemma n_n_top_n_top_split_n_n_top_top_1: "x * bot ⊔ n(x * n(y) * top) * top ≤ n(x) * top ⊔ x * n(y) * top" nitpick [expect=genuine,card=5] oops
lemma n_n_top_n_top_split_n_n_top_top_2: "n(x) * top ⊔ x * n(y) * top ≤ x * bot ⊔ n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
lemma n_nL_top_n_top_meet_L_top: "n(L) * x * top = n(x * top ⊓ L) * top" nitpick [expect=genuine,card=2] oops
lemma l18: "n(x) * L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
lemma l22: "x * bot ⊓ L = n(x) * L" nitpick [expect=genuine,card=2] oops
lemma l22_1: "x * bot ⊓ L = n(x * L) * L" nitpick [expect=genuine,card=2] oops
lemma l22_2: "x ⊓ L = n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l22_3: "x ⊓ L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
lemma l22_4: "x ⊓ L ≤ n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l22_5: "x * bot ⊓ L ≤ n(x) * L" nitpick [expect=genuine,card=4] oops
lemma l23: "x * top ⊓ L = n(x) * L" nitpick [expect=genuine,card=3] oops
lemma l51: "n(x) * L = (x ⊓ L) * bot" nitpick [expect=genuine,card=2] oops
lemma l91: "x = x * top ⟶ n(L) * x ≤ n(x) * top" nitpick [expect=genuine,card=3] oops
lemma l92: "x = x * top ⟶ n(L) * x ≤ n(x ⊓ L) * top" nitpick [expect=genuine,card=3] oops
lemma "x ⊓ L ≤ n(x) * top" nitpick [expect=genuine,card=3] oops
lemma n_meet_comp: "n(x) ⊓ n(y) ≤ n(x) * n(y)" nitpick [expect=genuine,card=3] oops

lemma n_n_meet_L_n_zero: "n(x) = (n(x) ⊓ L) ⊔ n(x * bot)" oops
lemma n_below_n_zero: "n(x) ≤ x ⊔ n(x * bot)" oops
lemma n_n_top_split_n_L_n_zero_top: "n(x) * top = n(x) * L ⊔ n(x * bot) * top" oops
lemma n_meet_L_0_0_meet_L: "(x ⊓ L) * bot = x * bot ⊓ L" oops
*)

end

end

Theory Recursion

(* Title:      Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Recursion›

theory Recursion

imports Approximation N_Algebras

begin

class n_algebra_apx = n_algebra + apx +
  assumes apx_def: "x  y  x  y  L  C y  x  n(x) * top"
begin

lemma apx_transitive_2:
  assumes "x  y"
      and "y  z"
    shows "x  z"
proof -
  have "C z  C (y  n(y) * top)"
    using assms(2) apx_def le_inf_iff by blast
  also have "... = C y  n(y) * top"
    by (simp add: C_n_mult_closed inf_sup_distrib1)
  also have "...  x  n(x) * top  n(y) * top"
    using assms(1) apx_def sup_left_isotone by blast
  also have "... = x  n(x) * top  n(C y) * top"
    by (simp add: n_C)
  also have "...  x  n(x) * top"
    by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show ?thesis
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed

lemma apx_meet_L:
  assumes "y  x"
    shows "x  L  y  L"
proof -
  have "x  L = C x  L"
    by (simp add: inf.left_commute inf.sup_monoid.add_assoc n_L_top_meet_L)
  also have "...  (y  n(y) * top)  L"
    using assms apx_def inf.sup_left_isotone by blast
  also have "... = (y  L)  (n(y) * top  L)"
    by (simp add: inf_sup_distrib2)
  also have "...  (y  L)  n(y  L) * top"
    using n_n_meet_L sup_right_isotone by force
  finally show ?thesis
    by (metis le_iff_sup inf_le2 n_less_eq_char)
qed

text ‹AACP Theorem 4.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def inf.coboundedI2)
  apply (metis sup_same_context order.antisym apx_def apx_meet_L relative_equality)
  using apx_transitive_2 by blast

lemma sup_apx_left_isotone_2:
  assumes "x  y"
    shows "x  z  y  z"
proof -
  have 1: "x  z  y  z  L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "C (y  z)  x  n(x) * top  C z"
    using assms apx_def inf_sup_distrib1 sup_left_isotone by auto
  also have "...  x  z  n(x) * top"
    using inf.coboundedI1 inf.sup_monoid.add_commute sup.cobounded1 sup.cobounded2 sup_assoc sup_least sup_right_isotone by auto
  also have "...  x  z  n(x  z) * top"
    using mult_isotone n_left_upper_bound semiring.add_left_mono by force
  finally show ?thesis
    using 1 apx_def by blast
qed

lemma mult_apx_left_isotone_2:
  assumes "x  y"
    shows "x * z  y * z"
proof -
  have "x * z  y * z  L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z  y * z  L"
    using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
  have "C (y * z) = C y * z"
    by (simp add: n_L_T_meet_mult)
  also have "...  x * z  n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "...  x * z  n(x * z) * top"
    by (simp add: n_top_split)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone_2:
  assumes "x  y"
    shows "z * x  z * y"
proof -
  have "z * x  z * y  z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "...  z * y  z * bot  L"
    using n_L_split_L semiring.add_left_mono sup_assoc by presburger
  finally have 1: "z * x  z * y  L"
    using mult_right_isotone sup.absorb_iff1 by auto
  have "C (z * y)  z * C y"
    by (simp add: n_L_T_meet_mult n_L_T_meet_mult_propagate)
  also have "...  z * (x  n(x) * top)"
    using assms apx_def mult_right_isotone by blast
  also have "... = z * x  z * n(x) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "...  z * x  n(z * x) * top"
    by (simp add: n_split_top)
  finally show ?thesis
    using 1 apx_def by blast
qed

text ‹AACP Theorem 4.1 and Theorem 4.2›

subclass apx_semiring
  apply unfold_locales
  apply (simp add: apx_def n_L_below_nL_top sup.absorb2)
  using sup_apx_left_isotone_2 apply blast
  using mult_apx_left_isotone_2 apply blast
  by (simp add: mult_apx_right_isotone_2)

text ‹AACP Theorem 4.2›

lemma meet_L_apx_isotone:
  "x  y  x  L  y  L"
  by (smt (verit) apx_meet_L apx_def inf.cobounded2 inf.left_commute n_L_top_meet_L n_less_eq_char sup.absorb2)

text ‹AACP Theorem 4.2›

lemma n_L_apx_isotone:
  assumes "x  y"
    shows "n(x) * L  n(y) * L"
proof -
  have "C (n(y) * L)  n(C y) * L"
    by (simp add: n_C)
  also have "...  n(x) * L  n(n(x) * L) * top"
    by (metis assms apx_def n_add_n_top n_galois n_isotone n_n_L)
  finally show ?thesis
    using apx_def le_inf_iff n_L_decreasing_meet_L sup.absorb2 by auto
qed

definition kappa_apx_meet :: "('a  'a)  bool"
  where "kappa_apx_meet f  apx.has_least_fixpoint f  has_apx_meet (μ f) (ν f)  κ f = μ f  ν f"

definition kappa_mu_nu :: "('a  'a)  bool"
  where "kappa_mu_nu f  apx.has_least_fixpoint f  κ f = μ f  (ν f  L)"

definition nu_below_mu_nu :: "('a  'a)  bool"
  where "nu_below_mu_nu f  C (ν f)  μ f  (ν f  L)  n(ν f) * top"

definition nu_below_mu_nu_2 :: "('a  'a)  bool"
  where "nu_below_mu_nu_2 f  C (ν f)  μ f  (ν f  L)  n(μ f  (ν f  L)) * top"

definition mu_nu_apx_nu :: "('a  'a)  bool"
  where "mu_nu_apx_nu f  μ f  (ν f  L)  ν f"

definition mu_nu_apx_meet :: "('a  'a)  bool"
  where "mu_nu_apx_meet f  has_apx_meet (μ f) (ν f)  μ f  ν f = μ f  (ν f  L)"

definition apx_meet_below_nu :: "('a  'a)  bool"
  where "apx_meet_below_nu f  has_apx_meet (μ f) (ν f)  μ f  ν f  ν f"

lemma mu_below_l:
  "μ f  μ f  (ν f  L)"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  μ f  (ν f  L)  ν f"
  by (simp add: mu_below_nu)

lemma n_l_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  (μ f  (ν f  L))  L = ν f  L"
  by (meson l_below_nu inf.cobounded1 inf.sup_same_context order_trans sup_ge2)

lemma l_apx_mu:
  "μ f  (ν f  L)  μ f"
proof -
  have 1: "μ f  (ν f  L)  μ f  L"
    using sup_right_isotone by auto
  have "C (μ f)  μ f  (ν f  L)  n(μ f  (ν f  L)) * top"
    by (simp add: le_supI1)
  thus ?thesis
    using 1 apx_def by blast
qed

text ‹AACP Theorem 4.8 implies Theorem 4.9›

lemma nu_below_mu_nu_nu_below_mu_nu_2:
  assumes "nu_below_mu_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  have "C (ν f) = C (C (ν f))"
    by auto
  also have "...  C (μ f  (ν f  L)  n(ν f) * top)"
    using assms nu_below_mu_nu_def by auto
  also have "... = C (μ f  (ν f  L))  C (n(ν f) * top)"
    using inf_sup_distrib1 by auto
  also have "... = C (μ f  (ν f  L))  n(ν f) * top"
    by (simp add: C_n_mult_closed)
  also have "...  μ f  (ν f  L)  n(ν f) * top"
    using inf_le2 sup_left_isotone by blast
  also have "... = μ f  (ν f  L)  n(ν f  L) * top"
    using n_n_meet_L by auto
  also have "...  μ f  (ν f  L)  n(μ f  (ν f  L)) * top"
    using mult_isotone n_right_upper_bound semiring.add_left_mono by auto
  finally show ?thesis
    by (simp add: nu_below_mu_nu_2_def)
qed

text ‹AACP Theorem 4.9 implies Theorem 4.8›

lemma nu_below_mu_nu_2_nu_below_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "nu_below_mu_nu f"
proof -
  have "C (ν f)  μ f  (ν f  L)  n(μ f  (ν f  L)) * top"
    using assms(3) nu_below_mu_nu_2_def by blast
  also have "...  μ f  (ν f  L)  n(ν f) * top"
    by (metis assms(1,2) order.eq_iff n_n_meet_L n_l_nu)
  finally show ?thesis
    using nu_below_mu_nu_def by blast
qed

lemma nu_below_mu_nu_equivalent:
  "has_least_fixpoint f  has_greatest_fixpoint f  (nu_below_mu_nu f  nu_below_mu_nu_2 f)"
  using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

text ‹AACP Theorem 4.9 implies Theorem 4.10›

lemma nu_below_mu_nu_2_mu_nu_apx_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "mu_nu_apx_nu f"
proof -
  have "μ f  (ν f  L)  ν f  L"
    using assms(1,2) l_below_nu le_supI1 by blast
  thus ?thesis
    using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed

text ‹AACP Theorem 4.10 implies Theorem 4.11›

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f  (ν f  L)"
  have "is_apx_meet (μ f) (ν f) ?l"
  proof (unfold is_apx_meet_def, intro conjI)
    show "?l  μ f"
      by (simp add: l_apx_mu)
    show "?l  ν f"
      using assms mu_nu_apx_nu_def by blast
    show "w. w  μ f  w  ν f  w  ?l"
      by (metis apx_meet_L le_inf_iff sup.absorb1 sup_apx_left_isotone)
  qed
  thus ?thesis
    by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed

text ‹AACP Theorem 4.11 implies Theorem 4.12›

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  mu_nu_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

text ‹AACP Theorem 4.12 implies Theorem 4.9›

lemma apx_meet_below_nu_nu_below_mu_nu_2:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  let ?l = "μ f  (ν f  L)"
  have "m . m  μ f  m  ν f  m  ν f  C (ν f)  ?l  n(?l) * top"
  proof
    fix m
    show "m  μ f  m  ν f  m  ν f  C (ν f)  ?l  n(?l) * top"
    proof
      assume 1: "m  μ f  m  ν f  m  ν f"
      hence "m  ?l"
        by (smt (z3) apx_def sup.left_commute sup_inf_distrib1 sup_left_divisibility)
      hence "m  n(m) * top  ?l  n(?l) * top"
        by (metis sup_mono mult_left_isotone n_isotone)
      thus "C (ν f)  ?l  n(?l) * top"
        using 1 apx_def order.trans by blast
    qed
  qed
  thus ?thesis
    by (smt (verit, ccfv_threshold) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed

text ‹AACP Theorem 4.5 implies Theorem 4.6›

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have 1: "w . w  μ f  w  ν f  C (κ f)  w  n(w) * top"
    by (metis assms(2,3) apx_def inf.sup_right_isotone order_trans kappa_below_nu)
  have "w . w  μ f  w  ν f  w  κ f  L"
    by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
  hence "w . w  μ f  w  ν f  w  κ f"
    using 1 apx_def by blast
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

text ‹AACP Theorem 4.6 implies Theorem 4.12›

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f  kappa_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

text ‹AACP Theorem 4.12 implies Theorem 4.7›

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f  (ν f  L)"
  let ?m = "μ f  ν f"
  have 1: "?m = ?l"
    by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
  have 2: "?l  f(?l)  L"
  proof -
    have "?l  μ f  L"
      using sup_right_isotone by auto
    also have "... = f(μ f)  L"
      by (simp add: assms(1) mu_unfold)
    also have "...  f(?l)  L"
      using assms(3) isotone_def sup_ge1 sup_left_isotone by blast
    finally show "?l  f(?l)  L"
      .
  qed
  have "C (f(?l))  ?l  n(?l) * top"
  proof -
    have "C (f(?l))  C (f(ν f))"
      using assms(1-3) l_below_nu inf.sup_right_isotone isotone_def by blast
    also have "... = C (ν f)"
      by (metis assms(2) nu_unfold)
    also have "...  ?l  n(?l) * top"
      by (metis assms(5) apx_meet_below_nu_nu_below_mu_nu_2 nu_below_mu_nu_2_def)
    finally show "C (f(?l))  ?l  n(?l) * top"
      .
  qed
  hence 3: "?l  f(?l)"
    using 2 apx_def by blast
  have 4: "f(?l)  μ f"
  proof -
    have "?l  μ f"
      by (simp add: l_apx_mu)
    thus "f(?l)  μ f"
      by (metis assms(1,4) mu_unfold ord.isotone_def)
  qed
  have "f(?l)  ν f"
  proof -
    have "?l  ν f"
      using 1
      by (metis apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def)
    thus "f(?l)  ν f"
      by (metis assms(2,4) nu_unfold ord.isotone_def)
  qed
  hence "f(?l)  ?l"
    using 1 4 apx_meet_below_nu_def assms(5) apx_meet is_apx_meet_def by fastforce
  hence 5: "f(?l) = ?l"
    using 3 apx.order.antisym by blast
  have "y . f(y) = y  ?l  y"
  proof
    fix y
    show "f(y) = y  ?l  y"
    proof
      assume 6: "f(y) = y"
      hence 7: "?l  y  L"
        using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
      have "y  ν f"
        using 6 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
      hence "C y  ?l  n(?l) * top"
        using assms(5) apx_meet_below_nu_nu_below_mu_nu_2 inf.sup_right_isotone nu_below_mu_nu_2_def order_trans by blast
      thus "?l  y"
        using 7 apx_def by blast
    qed
  qed
  thus ?thesis
    using 5 apx.least_fixpoint_same apx.has_least_fixpoint_def apx.is_least_fixpoint_def kappa_mu_nu_def by auto
qed

text ‹AACP Theorem 4.7 implies Theorem 4.5›

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f  apx.has_least_fixpoint f"
  by (simp add: kappa_mu_nu_def)

text ‹AACP Theorem 4.8 implies Theorem 4.7›

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu f  kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

text ‹AACP Theorem 4.7 implies Theorem 4.8›

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu f  nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_has_apx_least_fixpoint nu_below_mu_nu_2_nu_below_mu_nu)

definition kappa_mu_nu_L :: "('a  'a)  bool"
  where "kappa_mu_nu_L f  apx.has_least_fixpoint f  κ f = μ f  n(ν f) * L"

definition nu_below_mu_nu_L :: "('a  'a)  bool"
  where "nu_below_mu_nu_L f  C (ν f)  μ f  n(ν f) * top"

definition mu_nu_apx_nu_L :: "('a  'a)  bool"
  where "mu_nu_apx_nu_L f  μ f  n(ν f) * L  ν f"

definition mu_nu_apx_meet_L :: "('a  'a)  bool"
  where "mu_nu_apx_meet_L f  has_apx_meet (μ f) (ν f)  μ f  ν f = μ f  n(ν f) * L"

lemma n_below_l:
  "x  n(y) * L  x  (y  L)"
  using n_L_decreasing_meet_L semiring.add_left_mono by auto

lemma n_equal_l:
  assumes "nu_below_mu_nu_L f"
    shows "μ f  n(ν f) * L = μ f  (ν f  L)"
proof -
  have "ν f  L  (μ f  n(ν f) * top)  L"
    by (meson assms order.trans inf.boundedI inf.cobounded2 meet_L_below_C nu_below_mu_nu_L_def)
  also have "...  μ f  (n(ν f) * top  L)"
    by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute inf_sup_distrib1)
  also have "...  μ f  n(ν f) * L"
    by (simp add: n_T_meet_L)
  finally have "μ f  (ν f  L)  μ f  n(ν f) * L"
    by simp
  thus "μ f  n(ν f) * L = μ f  (ν f  L)"
    by (meson order.antisym n_below_l)
qed

text ‹AACP Theorem 4.14 implies Theorem 4.8›

lemma nu_below_mu_nu_L_nu_below_mu_nu:
  "nu_below_mu_nu_L f  nu_below_mu_nu f"
  by (metis sup_assoc sup_right_top mult_left_dist_sup n_equal_l nu_below_mu_nu_L_def nu_below_mu_nu_def)

text ‹AACP Theorem 4.14 implies Theorem 4.13›

lemma nu_below_mu_nu_L_kappa_mu_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu_L f  kappa_mu_nu_L f"
  using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by force

text ‹AACP Theorem 4.14 implies Theorem 4.15›

lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  nu_below_mu_nu_L f  mu_nu_apx_nu_L f"
  using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

text ‹AACP Theorem 4.14 implies Theorem 4.16›

lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  nu_below_mu_nu_L f  mu_nu_apx_meet_L f"
  using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

text ‹AACP Theorem 4.15 implies Theorem 4.14›

lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu_L f"
    shows "nu_below_mu_nu_L f"
proof -
  let ?n = "μ f  n(ν f) * L"
  let ?l = "μ f  (ν f  L)"
  have "C (ν f)  ?n  n(?n) * top"
    using assms(3) apx_def mu_nu_apx_nu_L_def by blast
  also have "...  ?n  n(?l) * top"
    using mult_left_isotone n_L_decreasing_meet_L n_isotone semiring.add_left_mono by auto
  also have "...  ?n  n(ν f) * top"
    using assms(1,2) l_below_nu mult_left_isotone n_isotone sup_right_isotone by auto
  finally show ?thesis
    by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed

text ‹AACP Theorem 4.13 implies Theorem 4.15›

lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
  "has_greatest_fixpoint f  kappa_mu_nu_L f  mu_nu_apx_nu_L f"
  using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by fastforce

text ‹AACP Theorem 4.16 implies Theorem 4.15›

lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
  "mu_nu_apx_meet_L f  mu_nu_apx_nu_L f"
  using apx_meet_char is_apx_meet_def mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce

text ‹AACP Theorem 4.13 implies Theorem 4.14›

lemma kappa_mu_nu_L_nu_below_mu_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu_L f  nu_below_mu_nu_L f"
  by (simp add: kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L)

(*
lemma nu_below_mu_nu_nu_below_mu_nu_L: "nu_below_mu_nu f ⟶ nu_below_mu_nu_L f" nitpick [expect=genuine,card=3] oops
*)

lemma unfold_fold_1:
  "isotone f  has_least_prefixpoint f  apx.has_least_fixpoint f  f(x)  x  κ f  x  L"
  by (metis sup_left_isotone apx_def has_least_fixpoint_def is_least_prefixpoint_def least_prefixpoint_char least_prefixpoint_fixpoint order_trans pmu_mu kappa_apx_below_mu)

lemma unfold_fold_2:
  assumes "isotone f"
      and "apx.isotone f"
      and "has_least_prefixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
      and "f(x)  x"
      and "κ f  L  x  L"
    shows "κ f  x"
proof -
  have "κ f  L = ν f  L"
    by (smt (z3) apx_meet_L assms(4,5) order.eq_iff inf.cobounded1 kappa_apx_below_nu kappa_below_nu le_inf_iff)
  hence "κ f = (κ f  L)  μ f"
    by (metis assms(1-5) apx_meet_below_nu_kappa_mu_nu has_apx_least_fixpoint_kappa_apx_meet sup_commute least_fixpoint_char least_prefixpoint_fixpoint kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)
  thus ?thesis
    by (metis assms(1,3,6,7) sup_least is_least_prefixpoint_def least_prefixpoint le_inf_iff pmu_mu)
qed

end

class n_algebra_apx_2 = n_algebra + apx +
  assumes apx_def: "x  y  x  y  L  y  x  n(x) * top"
begin

lemma apx_transitive_2:
  assumes "x  y"
      and "y  z"
    shows "x  z"
proof -
  have "z  y  n(y) * top"
    using assms(2) apx_def by auto
  also have "...  x  n(x) * top  n(y) * top"
    using assms(1) apx_def sup_left_isotone by blast
  also have "...  x  n(x) * top"
    by (metis assms(1) sup_assoc sup_idem sup_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show ?thesis
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
qed

lemma apx_meet_L:
  assumes "y  x"
    shows "x  L  y  L"
proof -
  have "x  L  (y  L)  (n(y) * top  L)"
    by (metis assms apx_def inf.sup_left_isotone inf_sup_distrib2)
  also have "...  (y  L)  n(y  L) * top"
    using n_n_meet_L sup_right_isotone by force
  finally show ?thesis
    by (metis le_iff_sup inf_le2 n_less_eq_char)
qed

text ‹AACP Theorem 4.1›

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def)
  using apx_def order.eq_iff n_less_eq_char apply blast
  using apx_transitive_2 by blast

lemma sup_apx_left_isotone_2:
  assumes "x  y"
    shows "x  z  y  z"
proof -
  have 1: "x  z  y  z  L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "y  z  x  n(x) * top  z"
    using assms apx_def sup_left_isotone by blast
  also have "...  x  z  n(x  z) * top"
    by (metis sup_assoc sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound)
  finally show ?thesis
    using 1 apx_def by auto
qed

lemma mult_apx_left_isotone_2:
  assumes "x  y"
    shows "x * z  y * z"
proof -
  have "x * z  y * z  L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z  y * z  L"
    using n_L_below_L order_lesseq_imp semiring.add_left_mono by blast
  have "y * z  x * z  n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "...  x * z  n(x * z) * top"
    by (simp add: n_top_split)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone_2:
  assumes "x  y"
    shows "z * x  z * y"
proof -
  have "z * x  z * y  z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "...  z * y  z * bot  L"
    using n_L_split_L semiring.add_left_mono sup_assoc by auto
  finally have 1: "z * x  z * y  L"
    using mult_right_isotone sup.absorb_iff1 by force
  have "z * y  z * (x  n(x) * top)"
    using assms apx_def mult_right_isotone by blast
  also have "... = z * x  z * n(x) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "...  z * x  n(z * x) * top"
    by (simp add: n_split_top)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

end

end

Theory N_Omega_Algebras

(* Title:      N-Omega-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Omega-Algebras›

theory N_Omega_Algebras

imports Omega_Algebras Recursion

begin

class itering_apx = bounded_itering + n_algebra_apx
begin

lemma circ_L:
  "L = L  1"
  by (metis sup_commute mult_top_circ n_L_top_L)

lemma C_circ_import:
  "C (x)  (C x)"
proof -
  have 1: "C x * x  (C x) * C x"
    using C_mult_propagate circ_simulate order.eq_iff by blast
  have "C (x) = C (1  x * x)"
    by (simp add: circ_left_unfold)
  also have "... = C 1  C (x * x)"
    by (simp add: inf_sup_distrib1)
  also have "...  1  C (x * x)"
    using sup_left_isotone by auto
  also have "... = 1  C x * x"
    by (simp add: n_L_T_meet_mult)
  also have "...  (C x)"
    using 1 by (meson circ_reflexive order.trans le_supI right_plus_below_circ)
  finally show ?thesis
    .
qed

text ‹AACP Theorem 4.3 and Theorem 4.4›

lemma circ_apx_isotone:
  assumes "x  y"
  shows "x  y"
proof -
  have 1: "x  y  L  C y  x  n(x) * top"
    using assms apx_def by auto
  have "C (y)  (C y)"
    by (simp add: C_circ_import)
  also have "...  x  x * n(x) * top"
    using 1 by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "...  x  (x * bot  n(x * x) * top)"
    using n_n_top_split_n_top sup_right_isotone by blast
  also have "...  x  (x * bot  n(x) * top)"
    using circ_plus_same left_plus_below_circ mult_left_isotone n_isotone sup_right_isotone by auto
  also have "... = x  n(x) * top"
    by (meson sup.left_idem sup_relative_same_increasing zero_right_mult_decreasing)
  finally have 2: "C (y)  x  n(x) * top"
    .
  have "x  y * L"
    using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone n_L_below_L le_iff_sup mult_assoc)
  also have "... = y  y * L"
    using circ_L mult_left_dist_sup sup_commute by auto
  also have "...  y  y * bot  L"
    using n_L_split_L semiring.add_left_mono sup_assoc by auto
  finally have "x  y  L"
    using sup.absorb1 zero_right_mult_decreasing by force
  thus "x  y"
    using 2 by (simp add: apx_def)
qed

end

class n_omega_algebra_1 = bounded_left_zero_omega_algebra + n_algebra_apx + Omega +
  assumes Omega_def: "xΩ = n(xω) * L  x"
begin

text ‹AACP Theorem 8.13›

lemma C_omega_export:
  "C (xω) = (C x)ω"
proof -
  have "C (xω) = C x * C (xω)"
    by (metis C_mult_propagate n_L_T_meet_mult omega_unfold)
  hence 1: "C (xω)  (C x)ω"
    using eq_refl omega_induct_mult by auto
  have "(C x)ω = C (x * (C x)ω)"
    using n_L_T_meet_mult omega_unfold by auto
  also have "...  C (xω)"
    by (metis calculation C_decreasing inf_le1 le_infI omega_induct_mult)
  finally show ?thesis
    using 1 order.antisym by blast
qed  

text ‹AACP Theorem 8.2›

lemma L_mult_star:
  "L * x = L"
  by (metis n_L_top_L star.circ_left_top mult_assoc)

text ‹AACP Theorem 8.3›

lemma mult_L_star:
  "(x * L) = 1  x * L"
  by (metis L_mult_star star.circ_mult_1 mult_assoc)

lemma mult_L_omega_below:
  "(x * L)ω  x * L"
  by (metis mult_right_isotone n_L_below_L omega_slide)

text ‹AACP Theorem 8.5›

lemma mult_L_sup_star:
  "(x * L  y) = y  y * x * L"
  using L_mult_star mult_1_right mult_left_dist_sup star_sup_1 sup_commute mult_L_star mult_assoc by auto

lemma mult_L_sup_omega_below:
  "(x * L  y)ω  yω  y * x * L"
proof -
  have "(x * L  y)ω  y * x * L  (y * x * L) * yω"
    by (metis sup_commute mult_assoc omega_decompose sup_left_isotone mult_L_omega_below)
  also have "...  yω  y * x * L"
    by (smt (z3) le_iff_sup le_supI mult_left_dist_sup n_L_below_L star_left_induct sup.cobounded2 sup.left_idem sup.orderE sup_assoc sup_commute mult_assoc)
  finally show ?thesis
    .
qed

lemma n_Omega_isotone:
  "x  y  xΩ  yΩ"
  by (metis Omega_def sup_mono mult_left_isotone n_isotone omega_isotone star_isotone)

lemma n_star_below_Omega:
  "x  xΩ"
  by (simp add: Omega_def)

lemma mult_L_star_mult_below:
  "(x * L) * y  y  x * L"
  by (metis sup_right_isotone mult_assoc mult_right_isotone n_L_below_L star_left_induct)

end

sublocale n_omega_algebra_1 < star: itering_apx where circ = star ..

class n_omega_algebra = n_omega_algebra_1 + n_algebra_apx +
  assumes n_split_omega_mult: "C (xω)  x * n(xω) * top"
  assumes tarski: "x * L  x * L * x * L"
begin

text ‹AACP Theorem 8.4›

lemma mult_L_omega:
  "(x * L)ω = x * L"
  apply (rule order.antisym)
  apply (rule mult_L_omega_below)
  using omega_induct_mult tarski mult_assoc by auto

text ‹AACP Theorem 8.6›

lemma mult_L_sup_omega:
  "(x * L  y)ω = yω  y * x * L"
  apply (rule order.antisym)
  apply (rule mult_L_sup_omega_below)
  by (metis le_supI omega_isotone omega_sub_dist_2 sup.cobounded2 sup_commute mult_L_omega mult_assoc)

text ‹AACP Theorem 8.1›

lemma tarski_mult_top_idempotent:
  "x * L = x * L * x * L"
  by (metis omega_unfold mult_L_omega mult_assoc)

text ‹AACP Theorem 8.7›

lemma n_below_n_omega:
  "n(x)  n(xω)"
proof -
  have "n(x) * L  n(x) * L * n(x) * L"
    by (simp add: tarski)
  also have "...  x * n(x) * L"
    by (simp add: mult_isotone n_L_decreasing)
  finally have "n(x) * L  xω"
    by (simp add: omega_induct_mult mult_assoc)
  thus ?thesis
    by (simp add: n_galois)
qed

text ‹AACP Theorem 8.14›

lemma n_split_omega_sup_zero:
  "C (xω)  x * bot  n(xω) * top"
proof -
  have "n(xω) * top  x * (x * bot  n(xω) * top) = n(xω) * top  x * x * bot  x * n(xω) * top"
    by (simp add: mult_left_dist_sup sup_assoc mult_assoc)
  also have "...  n(xω) * top  x * x * bot  x * bot  n(xω) * top"
    by (metis sup_assoc sup_right_isotone n_n_top_split_n_top omega_unfold)
  also have "... = x * x * bot  n(xω) * top"
    by (smt sup_assoc sup_commute sup_left_top sup_bot_right mult_assoc mult_left_dist_sup)
  also have "...  x * bot  n(xω) * top"
    by (metis sup_left_isotone mult_left_isotone star.left_plus_below_circ)
  finally have "x * n(xω) * top  x * bot  n(xω) * top"
    using star_left_induct mult_assoc by auto
  thus ?thesis
    using n_split_omega_mult order_trans by blast
qed

lemma n_split_omega_sup:
  "C (xω)  x  n(xω) * top"
  by (metis sup_left_isotone n_split_omega_sup_zero order_trans zero_right_mult_decreasing)

text ‹AACP Theorem 8.12›

lemma n_dist_omega_star:
  "n(yω  y * z) = n(yω)  n(y * z)"
proof -
  have "n(yω  y * z) = n(C (yω)  C (y * z))"
    by (metis inf_sup_distrib1 n_C)
  also have "...  n(C (yω)  y * z)"
    using n_isotone semiring.add_right_mono sup_commute by auto
  also have "...  n(y * bot  n(yω) * top  y * z)"
    using n_isotone semiring.add_right_mono n_split_omega_sup_zero by blast
  also have "... = n(yω)  n(y * z)"
    by (smt sup_assoc sup_commute sup_bot_right mult_left_dist_sup n_dist_n_add)
  finally show ?thesis
    by (simp add: order.antisym n_isotone)
qed

lemma mult_L_sup_circ_below:
  "(x * L  y)Ω  n(yω) * L  y  y * x * L"
proof -
  have "(x * L  y)Ω  n(yω  y * x * L) * L  (x * L  y)"
    by (simp add: Omega_def mult_L_sup_omega)
  also have "... = n(yω) * L  n(y * x * L) * L  (x * L  y)"
    by (simp add: semiring.distrib_right mult_assoc n_dist_omega_star)
  also have "...  n(yω) * L  y  y * x * L"
    by (smt (z3) le_supI sup.cobounded1 sup_assoc sup_commute sup_idem sup_right_isotone mult_L_sup_star n_L_decreasing)
  finally show ?thesis
    .
qed

lemma n_mult_omega_L_below_zero:
  "n(y * xω) * L  y * x * bot  y * n(xω) * L"
proof -
  have "n(y * xω) * L  C (y * xω)  L"
    by (metis n_C n_L_decreasing_meet_L)
  also have "...  y * C (xω)  L"
    using inf.sup_left_isotone n_L_T_meet_mult n_L_T_meet_mult_propagate by auto
  also have "...  y * (x * bot  n(xω) * top)  L"
    using inf.sup_left_isotone mult_right_isotone n_split_omega_sup_zero by auto
  also have "... = (y * x * bot  L)  (y * n(xω) * top  L)"
    using inf_sup_distrib2 mult_left_dist_sup mult_assoc by auto
  also have "...  (y * x * bot  L)  y * n(xω) * L"
    using n_vector_meet_L sup_right_isotone by auto
  also have "...  y * x * bot  y * n(xω) * L"
    using sup_left_isotone by auto
  finally show ?thesis
    .
qed

text ‹AACP Theorem 8.10›

lemma n_mult_omega_L_star_zero:
  "y * x * bot  n(y * xω) * L = y * x * bot  y * n(xω) * L"
  apply (rule order.antisym)
  apply (simp add: n_mult_omega_L_below_zero)
  by (smt sup_assoc sup_commute sup_bot_left sup_right_isotone mult_assoc mult_left_dist_sup n_n_L_split_n_L)

text ‹AACP Theorem 8.11›

lemma n_mult_omega_L_star:
  "y * x  n(y * xω) * L = y * x  y * n(xω) * L"
  by (metis zero_right_mult_decreasing n_mult_omega_L_star_zero sup_relative_same_increasing)

lemma n_mult_omega_L_below:
  "n(y * xω) * L  y * x  y * n(xω) * L"
  using sup_right_divisibility n_mult_omega_L_star by blast

lemma n_omega_L_below_zero:
  "n(xω) * L  x * x * bot  x * n(xω) * L"
  by (metis omega_unfold n_mult_omega_L_below_zero)

lemma n_omega_L_below:
  "n(xω) * L  x  x * n(xω) * L"
  by (metis omega_unfold n_mult_omega_L_below sup_left_isotone star.left_plus_below_circ order_trans)

lemma n_omega_L_star_zero:
  "x * x * bot  n(xω) * L = x * x * bot  x * n(xω) * L"
  by (metis n_mult_omega_L_star_zero omega_unfold)

text ‹AACP Theorem 8.8›

lemma n_omega_L_star:
  "x  n(xω) * L = x  x * n(xω) * L"
  by (metis star.circ_mult_upper_bound star.left_plus_below_circ bot_least n_omega_L_star_zero sup_relative_same_increasing)

text ‹AACP Theorem 8.9›

lemma n_omega_L_star_zero_star:
  "x * bot  n(xω) * L = x * bot  x * n(xω) * L"
  by (metis n_mult_omega_L_star_zero star_mult_omega mult_assoc star.circ_transitive_equal)

text ‹AACP Theorem 8.8›

lemma n_omega_L_star_star:
  "x  n(xω) * L = x  x * n(xω) * L"
  by (metis zero_right_mult_decreasing n_omega_L_star_zero_star sup_relative_same_increasing)

lemma n_Omega_left_unfold:
  "1  x * xΩ = xΩ"
  by (smt Omega_def sup_assoc sup_commute mult_assoc mult_left_dist_sup n_omega_L_star star.circ_left_unfold)

lemma n_Omega_left_slide:
  "(x * y)Ω * x  x * (y * x)Ω"
proof -
  have "(x * y)Ω * x  x * y * n((x * y)ω) * L  (x * y) * x"
    by (smt Omega_def sup_commute sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L n_omega_L_star)
  also have "...  x * (y * bot  n(y * (x * y)ω) * L)  (x * y) * x"
    by (metis mult_right_isotone n_n_L_split_n_L sup_commute sup_right_isotone mult_assoc)
  also have "... = x * (y * x)Ω"
    by (smt (verit, del_insts) le_supI1 star_slide Omega_def sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_dist_sup omega_slide star.circ_increasing star.circ_slide bot_least)
  finally show ?thesis
    .
qed

lemma n_Omega_sup_1:
  "(x  y)Ω = xΩ * (y * xΩ)Ω"
proof -
  have 1: "(x  y)Ω = n((x * y)ω) * L  n((x * y) * xω) * L  (x * y) * x"
    by (simp add: Omega_def omega_decompose semiring.distrib_right star.circ_sup_9 n_dist_omega_star)
  have "n((x * y)ω) * L  (x * y)  x * (y * n((x * y)ω) * L)"
    by (metis n_omega_L_below mult_assoc)
  also have "...  (x * y)  x * y * bot  x * n((y * x)ω) * L"
    by (smt sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone n_n_L_split_n_L omega_slide)
  also have "... = (x * y)  x * n((y * x)ω) * L"
    by (metis sup_commute le_iff_sup star.circ_sub_dist_1 zero_right_mult_decreasing)
  also have "...  x * (y * x)  x * n((y * x)ω) * L"
    by (metis star_outer_increasing star_slide star_star_absorb sup_left_isotone)
  also have "...  x * (y * xΩ)Ω"
    by (metis Omega_def sup_commute mult_assoc mult_left_dist_sup mult_right_isotone n_Omega_isotone n_star_below_Omega)
  also have "...  xΩ * (y * xΩ)Ω"
    by (simp add: mult_left_isotone n_star_below_Omega)
  finally have 2: "n((x * y)ω) * L  xΩ * (y * xΩ)Ω"
    .
  have "n((x * y) * xω) * L  n(xω) * L  x * (y * x)  x * (y * x) * y * n(xω) * L"
    by (smt sup_assoc sup_commute mult_left_one mult_right_dist_sup n_mult_omega_L_below star.circ_mult star.circ_slide)
  also have "... = n(xω) * L * (y * xΩ)  x * (y * xΩ)"
    by (smt Omega_def sup_assoc mult_L_sup_star mult_assoc mult_left_dist_sup L_mult_star)
  also have "...  xΩ * (y * xΩ)Ω"
    by (simp add: Omega_def mult_isotone)
  finally have 3: "n((x * y) * xω) * L  xΩ * (y * xΩ)Ω"
    .
  have "(x * y) * x  xΩ * (y * xΩ)Ω"
    by (metis star_slide mult_isotone mult_right_isotone n_star_below_Omega order_trans star_isotone)
  hence 4: "(x  y)Ω  xΩ * (y * xΩ)Ω"
    using 1 2 3 by simp
  have 5: "xΩ * (y * xΩ)Ω  n(xω) * L  x * n((y * xΩ)ω) * L  x * (y * xΩ)"
    by (smt Omega_def sup_assoc sup_left_isotone mult_assoc mult_left_dist_sup mult_right_dist_sup mult_right_isotone n_L_below_L)
  have "n(xω) * L  n((x * y) * xω) * L"
    by (metis sup_commute sup_ge1 mult_left_isotone n_isotone star.circ_loop_fixpoint)
  hence 6: "n(xω) * L  (x  y)Ω"
    using 1 order_lesseq_imp by fastforce
  have "x * n((y * xΩ)ω) * L  x * n((y * x)ω  (y * x) * y * n(xω) * L) * L"
    by (metis Omega_def mult_L_sup_omega_below mult_assoc mult_left_dist_sup mult_left_isotone mult_right_isotone n_isotone)
  also have "...  x * bot  n(x * ((y * x)ω  (y * x) * y * n(xω) * L)) * L"
    by (simp add: n_n_L_split_n_L)
  also have "...  x  n((x * y)ω  x * (y * x) * y * n(xω) * L) * L"
    using omega_slide semiring.distrib_left sup_mono zero_right_mult_decreasing mult_assoc by fastforce
  also have "...  x  n((x * y)ω  (x * y) * n(xω) * L) * L"
    by (smt sup_right_divisibility sup_right_isotone mult_left_isotone n_isotone star.circ_mult)
  also have "...  x  n((x  y)ω) * L"
    by (metis sup_right_isotone mult_assoc mult_left_isotone mult_right_isotone n_L_decreasing n_isotone omega_decompose)
  also have "...  (x  y)Ω"
    by (simp add: Omega_def le_supI1 star_isotone sup_commute)
  finally have 7: "x * n((y * xΩ)ω) * L  (x  y)Ω"
    .
  have "x * (y * xΩ)  (x * y) * x  (x * y) * n(xω) * L"
    by (smt Omega_def sup_right_isotone mult_L_sup_star mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ star_slide)
  also have "...  (x * y) * x  n((x * y) * xω) * L"
    by (simp add: n_mult_omega_L_star)
  also have "...  (x  y)Ω"
    by (smt Omega_def sup_commute sup_right_isotone mult_left_isotone n_right_upper_bound omega_decompose star.circ_sup)
  finally have "n(xω) * L  x * n((y * xΩ)ω) * L  x * (y * xΩ)  (x  y)Ω"
    using 6 7 by simp
  hence "xΩ * (y * xΩ)Ω  (x  y)Ω"
    using 5 order.trans by blast
  thus ?thesis
    using 4 order.antisym by blast
qed

end

sublocale n_omega_algebra < nL_omega: left_zero_conway_semiring where circ = Omega
  apply unfold_locales
  apply (simp add: n_Omega_left_unfold)
  apply (simp add: n_Omega_left_slide)
  by (simp add: n_Omega_sup_1)

(* circ_plus_same does not hold in the non-strict model using Omega *)

context n_omega_algebra
begin

text ‹AACP Theorem 8.16›

lemma omega_apx_isotone:
  assumes "x  y"
    shows "xω  yω"
proof -
  have 1: "x  y  L  C y  x  n(x) * top"
    using assms apx_def by auto
  have "n(x) * top  x * (xω  n(xω) * top)  n(x) * top  xω  n(xω) * top"
    by (metis le_supI n_split_top sup.cobounded1 sup_assoc mult_assoc mult_left_dist_sup sup_right_isotone omega_unfold)
  also have "...  xω  n(xω) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_below_n_omega sup_assoc sup_idem)
  finally have 2: "x * n(x) * top  xω  n(xω) * top"
    using star_left_induct mult_assoc by auto
  have "C (yω) = (C y)ω"
    by (simp add: C_omega_export)
  also have "...  (x  n(x) * top)ω"
    using 1 omega_isotone by blast
  also have "... = (x * n(x) * top)ω  (x * n(x) * top) * xω"
    by (simp add: omega_decompose mult_assoc)
  also have "...  x * n(x) * top  (x * n(x) * top) * xω"
    using mult_top_omega sup_left_isotone by blast
  also have "... = x * n(x) * top  (1  x * n(x) * top * (x * n(x) * top)) * xω"
    by (simp add: star_left_unfold_equal)
  also have "...  xω  x * n(x) * top"
    by (smt sup_mono sup_least mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest sup.cobounded2)
  also have "...  xω  n(xω) * top"
    using 2 by simp
  finally have 3: "C (yω)  xω  n(xω) * top"
    .
  have "xω  (y  L)ω"
    using 1 omega_isotone by simp
  also have "... = (y * L)ω  (y * L) * yω"
    by (simp add: omega_decompose)
  also have "... = y * L * (y * L)ω  (y * L) * yω"
    using omega_unfold by auto
  also have "...  y * L  (y * L) * yω"
    by (metis sup_left_isotone n_L_below_L mult_assoc mult_right_isotone)
  also have "... = y * L  (1  y * L * (y * L)) * yω"
    by (simp add: star_left_unfold_equal)
  also have "...  y * L  yω"
    by (simp add: mult_L_star_mult_below star_left_unfold_equal sup_commute)
  also have "...  y * bot  L  yω"
    using n_L_split_L sup_left_isotone by auto
  finally have "xω  yω  L"
    by (simp add: star_bot_below_omega sup.absorb1 sup.left_commute sup_commute)
  thus "xω  yω"
    using 3 by (simp add: apx_def)
qed

lemma combined_apx_left_isotone:
  "x  y  n(xω) * L  x * z  n(yω) * L  y * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_left_isotone_2:
  "x  y  (xω  L)  x * z  (yω  L)  y * z"
  by (metis sup_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)

lemma combined_apx_right_isotone:
  "y  z  n(xω) * L  x * y  n(xω) * L  x * z"
  by (simp add: mult_apx_isotone sup_apx_left_isotone sup_commute)

lemma combined_apx_right_isotone_2:
  "y  z  (xω  L)  x * y  (xω  L)  x * z"
  by (simp add: mult_apx_right_isotone sup_apx_right_isotone)

lemma combined_apx_isotone:
  "x  y  w  z  n(xω) * L  x * w  n(yω) * L  y * z"
  by (simp add: mult_apx_isotone n_L_apx_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone)

lemma combined_apx_isotone_2:
  "x  y  w  z  (xω  L)  x * w  (yω  L)  y * z"
  by (meson combined_apx_left_isotone_2 combined_apx_right_isotone_2 apx.order.trans)

lemma n_split_nu_mu:
  "C (yω  y * z)  y * z  n(yω  y * z) * top"
proof -
  have "C (yω  y * z)  C (yω)  y * z"
    by (simp add: inf_sup_distrib1 le_supI1 sup_commute)
  also have "...  y * bot  n(yω) * top  y * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "...  y * z  n(yω  y * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound sup_right_isotone by force
  finally show ?thesis
    .
qed

lemma n_split_nu_mu_2:
  "C (yω  y * z)  y * z  ((yω  y * z)  L)  n(yω  y * z) * top"
proof -
  have "C (yω  y * z)  C (yω)  y * z"
    using inf.sup_left_isotone sup_inf_distrib2 by auto
  also have "...  y * bot  n(yω) * top  y * z"
    using n_split_omega_sup_zero sup_left_isotone by blast
  also have "...  y * z  n(yω  y * z) * top"
    using le_supI1 mult_left_isotone mult_right_isotone n_left_upper_bound semiring.add_left_mono by auto
  finally show ?thesis
    using order_lesseq_imp semiring.add_right_mono sup.cobounded1 by blast
qed

lemma loop_exists:
  "C (ν (λx . y * x  z))  μ (λx . y * x  z)  n(ν (λx . y * x  z)) * top"
  using omega_loop_nu star_loop_mu n_split_nu_mu by auto

lemma loop_exists_2:
  "C (ν (λx . y * x  z))  μ (λx . y * x  z)  (ν (λx . y * x  z)  L)  n(ν (λx . y * x  z)) * top"
  by (simp add: omega_loop_nu star_loop_mu n_split_nu_mu_2)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x  z) (μ (λx . y * x  z)  n(ν (λx . y * x  z)) * L)"
proof -
  have "kappa_mu_nu_L (λx . y * x  z)"
    by (metis affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_L_def nu_below_mu_nu_L_kappa_mu_nu_L)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_L_def by force
qed

lemma loop_apx_least_fixpoint_2:
  "apx.is_least_fixpoint (λx . y * x  z) (μ (λx . y * x  z)  (ν (λx . y * x  z)  L))"
proof -
  have "kappa_mu_nu (λx . y * x  z)"
    by (metis affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone loop_exists_2 nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu)
  thus ?thesis
    using apx.least_fixpoint_char kappa_mu_nu_def by force
qed

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x  z)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by blast

lemma loop_semantics:
  "κ (λx . y * x  z) = μ (λx . y * x  z)  n(ν (λx . y * x  z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by force

lemma loop_semantics_2:
  "κ (λx . y * x  z) = μ (λx . y * x  z)  (ν (λx . y * x  z)  L)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint_2 by force

text ‹AACP Theorem 8.15›

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x  z) = n(yω) * L  y * z"
proof -
  have "κ (λx . y * x  z) = y * z  n(yω  y * z) * L"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint by auto
  thus ?thesis
    by (smt n_dist_omega_star sup_assoc mult_right_dist_sup sup_commute le_iff_sup n_L_decreasing)
qed

text ‹AACP Theorem 8.15›

lemma loop_semantics_kappa_mu_nu_2:
  "κ (λx . y * x  z) = (yω  L)  y * z"
proof -
  have "κ (λx . y * x  z) = y * z  ((yω  y * z)  L)"
    using apx.least_fixpoint_char omega_loop_nu star_loop_mu loop_apx_least_fixpoint_2 by auto
  thus ?thesis
    by (metis sup_absorb2 sup_ge2 sup_inf_distrib1 sup_monoid.add_commute)
qed

text ‹AACP Theorem 8.16›

lemma loop_semantics_apx_left_isotone:
  "w  y  κ (λx . w * x  z)  κ (λx . y * x  z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_left_isotone_2)

text ‹AACP Theorem 8.16›

lemma loop_semantics_apx_right_isotone:
  "w  z  κ (λx . y * x  w)  κ (λx . y * x  z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_right_isotone_2)

lemma loop_semantics_apx_isotone:
  "v  y  w  z  κ (λx . v * x  w)  κ (λx . y * x  z)"
  using apx_transitive_2 loop_semantics_apx_left_isotone loop_semantics_apx_right_isotone by blast

end

end

Theory N_Omega_Binary_Iterings

(* Title:      N-Omega Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Omega Binary Iterings›

theory N_Omega_Binary_Iterings

imports N_Omega_Algebras Binary_Iterings_Strict

begin

sublocale extended_binary_itering < left_zero_conway_semiring where circ = "(λx . x  1)"
  apply unfold_locales
  using while_left_unfold apply force
  apply (metis mult_1_right while_one_mult_below while_slide)
  by (simp add: while_one_while while_sumstar_2)

class binary_itering_apx = bounded_binary_itering + n_algebra_apx
begin

lemma C_while_import:
  "C (x  z) = C (C x  z)"
proof -
  have 1: "C x * (x  z)  C x  (C x * z)"
    using C_mult_propagate while_simulate by force
  have "C (x  z) = C z  C x * (x  z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "...  C x  z"
    using 1 by (metis C_decreasing sup_mono while_right_unfold)
  finally have "C (x  z)  C (C x  z)"
    by simp
  thus ?thesis
    by (metis order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute while_absorb_2 while_increasing)
qed

lemma C_while_preserve:
  "C (x  z) = C (x  C z)"
proof -
  have "C x * (x  z)  C x  (C x * z)"
    using C_mult_propagate while_simulate by auto
  also have "...  x  (x * C z)"
    using C_decreasing n_L_T_meet_mult_propagate while_isotone by blast
  finally have 1: "C x * (x  z)  x  (x * C z)"
    .
  have "C (x  z) = C z  C x * (x  z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "...  x  C z"
    using 1 by (meson order.trans le_supI while_increasing while_right_plus_below)
  finally have "C (x  z)  C (x  C z)"
    by simp
  thus ?thesis
    by (meson order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.eq_refl while_isotone)
qed

lemma C_while_import_preserve:
  "C (x  z) = C (C x  C z)"
  using C_while_import C_while_preserve by auto

lemma while_L_L:
  "L  L = L"
  by (metis n_L_top_L while_mult_star_exchange while_right_top)

lemma while_L_below_sup:
  "L  x  x  L"
  by (metis while_left_unfold sup_right_isotone n_L_below_L)

lemma while_L_split:
  "x  L  (x  y)  L"
proof -
  have "x  L  (x  bot)  L"
    by (metis sup_commute sup_bot_left mult_1_right n_L_split_L while_right_unfold while_simulate_left_plus while_zero)
  thus ?thesis
    by (metis sup_commute sup_right_isotone order_trans while_right_isotone bot_least)
qed

lemma while_n_while_top_split:
  "x  (n(x  y) * top)  (x  bot)  n(x  y) * top"
proof -
  have "x * n(x  y) * top  x * bot  n(x * (x  y)) * top"
    by (simp add: n_n_top_split_n_top)
  also have "...  n(x  y) * top  x * bot"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_isotone while_left_plus_below)
  finally have "x  (n(x  y) * top)  n(x  y) * top  (x  (x * bot))"
    by (metis mult_assoc mult_1_right while_simulate_left mult_left_zero while_left_top)
  also have "...  (x  bot)  n(x  y) * top"
    using sup_left_isotone while_right_plus_below by auto
  finally show ?thesis
    .
qed

lemma circ_apx_right_isotone:
  assumes "x  y"
    shows "z  x  z  y"
proof -
  have 1: "x  y  L  C y  x  n(x) * top"
    using assms apx_def by auto
  hence "z  x  (z  y)  (z  L)"
    by (metis while_left_dist_sup while_right_isotone)
  hence 2: "z  x  (z  y)  L"
    by (meson le_supI order_lesseq_imp sup.cobounded1 while_L_split)
  have "z  (n(z  x) * top)  (z  bot)  n(z  x) * top"
    by (simp add: while_n_while_top_split)
  also have "...  (z  x)  n(z  x) * top"
    using sup_left_isotone while_right_isotone by force
  finally have 3: "z  (n(x) * top)  (z  x)  n(z  x) * top"
    by (metis mult_left_isotone n_isotone order_trans while_increasing while_right_isotone)
  have "C (z  y)  z  C y"
    by (metis C_while_preserve inf.cobounded2)
  also have "...  (z  x)  (z  (n(x) * top))"
    using 1 by (metis while_left_dist_sup while_right_isotone)
  also have "...  (z  x)  n(z  x) * top"
    using 3 by simp
  finally show ?thesis
    using 2 apx_def by auto
qed

end

class extended_binary_itering_apx = binary_itering_apx + bounded_extended_binary_itering +
  assumes n_below_while_zero: "n(x)  n(x  bot)"
begin

lemma circ_apx_right_isotone:
  assumes "x  y"
    shows "x  z  y  z"
proof -
  have 1: "x  y  L  C y  x  n(x) * top"
    using assms apx_def by auto
  hence "x  z  ((y  1) * L)  (y  z)"
    by (metis while_left_isotone while_sumstar_3)
  also have "...  (y  z)  (y  1) * L"
    by (metis while_productstar sup_right_isotone mult_right_isotone n_L_below_L while_slide)
  also have "...  (y  z)  L"
    by (meson order.trans le_supI sup.cobounded1 while_L_split while_one_mult_below)
  finally have 2: "x  z  (y  z)  L"
    .
  have "C (y  z)  C y  z"
    by (metis C_while_import inf.sup_right_divisibility)
  also have "...  ((x  1) * n(x) * top)  (x  z)"
    using 1 by (metis while_left_isotone mult_assoc while_sumstar_3)
  also have "...  (x  z)  (x  1) * n(x) * top"
    by (metis while_productstar sup_left_top sup_right_isotone mult_assoc mult_left_sub_dist_sup_right while_slide)
  also have "...  (x  z)  (x  (n(x) * top))"
    using sup_right_isotone while_one_mult_below mult_assoc by auto
  also have "...  (x  z)  (x  (n(x  z) * top))"
    by (metis n_below_while_zero bot_least while_right_isotone n_isotone mult_left_isotone sup_right_isotone order_trans)
  also have "...  (x  z)  n(x  z) * top"
    by (metis sup_assoc sup_right_isotone while_n_while_top_split sup_bot_right while_left_dist_sup)
  finally show ?thesis
    using 2 apx_def by auto
qed

(*
lemma while_top: "top ⋆ x = L ⊔ top * x" oops
lemma while_one_top: "1 ⋆ x = L ⊔ x" oops
lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" oops

lemma while_square_1: "x ⋆ 1 = (x * x) ⋆ (x ⊔ 1)" oops
lemma while_absorb_below_one: "y * x ≤ x ⟹ y ⋆ x ≤ 1 ⋆ x" oops
lemma while_mult_L: "(x * L) ⋆ z = z ⊔ x * L" oops
lemma tarski_top_omega_below_2: "x * L ≤ (x * L) ⋆ bot" oops
lemma tarski_top_omega_2: "x * L = (x * L) ⋆ bot" oops
lemma while_separate_right_plus: "y * x ≤ x * (x ⋆ (1 ⊔ y)) ⊔ 1 ⟹ y ⋆ (x ⋆ z) ≤ x ⋆ (y ⋆ z)" oops
lemma "y ⋆ (x ⋆ 1) ≤ x ⋆ (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
lemma "y * x ≤ (1 ⊔ x) * (y ⋆ 1) ⟹ (x ⊔ y) ⋆ 1 = x ⋆ (y ⋆ 1)" oops
*)

end

class n_omega_algebra_binary = n_omega_algebra + while +
  assumes while_def: "x  y = n(xω) * L  x * y"
begin

lemma while_omega_inf_L_star:
  "x  y = (xω  L)  x * y"
  by (metis loop_semantics_kappa_mu_nu loop_semantics_kappa_mu_nu_2 while_def)

lemma while_one_mult_while_below_1:
  "(y  1) * (y  v)  y  v"
proof -
  have "(y  1) * (y  v)  y  (y  v)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def mult_left_one)
  also have "... = n(yω) * L  y * n(yω) * L  y * y * v"
    by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)
  also have "... = n(yω) * L  (y * y * bot  y * n(yω) * L)  y * y * v"
    by (metis mult_left_dist_sup star.circ_transitive_equal sup_bot_left mult_assoc)
  also have "... = n(yω) * L  (y * y * bot  n(y * yω) * L)  y * y * v"
    by (simp add: n_mult_omega_L_star_zero)
  also have "... = n(yω) * L  n(y * yω) * L  y * y * v"
    by (smt (z3) mult_left_dist_sup sup.left_commute sup_bot_left sup_commute)
  finally show ?thesis
    by (simp add: star.circ_transitive_equal star_mult_omega while_def)
qed

lemma star_below_while:
  "x * y  x  y"
  by (simp add: while_def)

subclass bounded_binary_itering
proof unfold_locales
  fix x y z
  have "z  x * ((y * x)  (y * z)) = x * (y * x) * y * z  x * n((y * x)ω) * L  z"
    using mult_left_dist_sup sup_commute while_def mult_assoc by auto
  also have "... = x * (y * x) * y * z  n(x * (y * x)ω) * L  z"
    by (metis mult_assoc mult_right_isotone bot_least n_mult_omega_L_star_zero sup_relative_same_increasing)
  also have "... = (x * y) * z  n(x * (y * x)ω) * L"
    by (smt sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star_slide)
  also have "... = (x * y)  z"
    by (simp add: omega_slide sup_monoid.add_commute while_def)
  finally show "(x * y)  z = z  x * ((y * x)  (y * z))"
    by simp
next
  fix x y z
  have "(x  y)  (x  z) = n((n(xω) * L  x * y)ω) * L  (n(xω) * L  x * y) * (x  z)"
    by (simp add: while_def)
  also have "... = n((x * y)ω  (x * y) * n(xω) * L) * L  ((x * y)  (x * y) * n(xω) * L) * (x  z)"
    using mult_L_sup_omega mult_L_sup_star by force
  also have "... = n((x * y)ω) * L  n((x * y) * n(xω) * L) * L  (x * y) * (x  z)  (x * y) * n(xω) * L * (x  z)"
    by (simp add: mult_right_dist_sup n_dist_omega_star sup_assoc mult_assoc)
  also have "... = n((x * y)ω) * L  n((x * y) * n(xω) * L) * L  (x * y) * bot  (x * y) * (x  z)  (x * y) * n(xω) * L * (x  z)"
    by (smt sup_assoc sup_bot_left mult_left_dist_sup)
  also have "... = n((x * y)ω) * L  ((x * y) * n(xω) * L * (x  z)  (x * y) * n(xω) * L  (x * y) * (x  z))"
    by (smt n_n_L_split_n_n_L_L sup_commute sup_assoc)
  also have "... = n((x * y)ω) * L  ((x * y) * n(xω) * L  (x * y) * (x  z))"
    by (smt mult_L_omega omega_sub_vector le_iff_sup)
  also have "... = n((x * y)ω) * L  (x * y) * (x  z)"
    using mult_left_sub_dist_sup_left sup_absorb2 while_def mult_assoc by auto
  also have "... = (x * y) * x * z  (x * y) * n(xω) * L  n((x * y)ω) * L"
    by (simp add: mult_left_dist_sup sup_commute while_def mult_assoc)
  also have "... = (x * y) * x * z  n((x * y) * xω) * L  n((x * y)ω) * L"
    by (metis sup_bot_right mult_left_dist_sup sup_assoc n_mult_omega_L_star_zero)
  also have "... = (x  y)  z"
    using n_dist_omega_star omega_decompose semiring.combine_common_factor star.circ_sup_9 sup_commute while_def by force
  finally show "(x  y)  z = (x  y)  (x  z)"
    by simp
next
  fix x y z
  show "x  (y  z) = (x  y)  (x  z)"
    using semiring.distrib_left sup_assoc sup_commute while_def by force
next
  fix x y z
  show "(x  y) * z  x  (y * z)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def)
next
  fix v w x y z
  show "x * z  z * (y  1)  w  x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
  proof
    assume 1: "x * z  z * (y  1)  w"
    have "z * v  x * (z * (y  v)  x * (w * (y  v)))  z * v  x * z * (y  v)  x * (w * (y  v))"
      by (metis sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ)
    also have "...  z * v  z * (y  1) * (y  v)  w * (y  v)  x * (w * (y  v))"
      using 1 by (metis sup_assoc sup_left_isotone sup_right_isotone mult_left_isotone mult_right_dist_sup)
    also have "...  z * v  z * (y  v)  x * (w * (y  v))"
      by (smt (verit, ccfv_threshold) sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_loop_fixpoint while_one_mult_while_below_1 le_supE le_supI)
    also have "... = z * (y  v)  x * (w * (y  v))"
      by (metis le_iff_sup le_supE mult_right_isotone star.circ_loop_fixpoint star_below_while)
    finally have "x * z * v  z * (y  v)  x * (w * (y  v))"
      using star_left_induct mult_assoc by auto
    thus "x  (z * v)  z * (y  v)  (x  (w * (y  v)))"
      by (smt sup_assoc sup_commute sup_right_isotone mult_assoc while_def)
  qed
next
  fix v w x y z
  show "z * x  y * (y  z)  w  z * (x  v)  y  (z * v  w * (x  v))"
  proof
    assume "z * x  y * (y  z)  w"
    hence 1: "z * x  y * y * z  (y * n(yω) * L  w)"
      by (simp add: mult_left_dist_sup sup.left_commute sup_commute while_def mult_assoc)
    hence "z * x  y * (z  (y * n(yω) * L  w) * x)"
      by (simp add: star_circ_simulate_right_plus)
    also have "... = y * z  y * y * n(yω) * L  y * w * x"
      by (simp add: L_mult_star semiring.distrib_left semiring.distrib_right sup_left_commute sup_monoid.add_commute mult_assoc)
    also have "... = y * z  n(y * y * yω) * L  y * w * x"
      by (metis sup_relative_same_increasing mult_isotone n_mult_omega_L_star_zero star.left_plus_below_circ star.right_plus_circ bot_least)
    also have "... = n(yω) * L  y * z  y * w * x"
      using omega_unfold star_mult_omega sup_commute mult_assoc by force
    finally have "z * x * v  n(yω) * L * v  y * z * v  y * w * x * v"
      by (smt le_iff_sup mult_right_dist_sup)
    also have "...  n(yω) * L  y * (z * v  w * x * v)"
      by (metis n_L_below_L mult_assoc mult_right_isotone sup_left_isotone mult_left_dist_sup sup_assoc)
    also have "...  n(yω) * L  y * (z * v  w * (x  v))"
      using mult_right_isotone semiring.add_left_mono mult_assoc star_below_while by auto
    finally have 2: "z * x * v  y  (z * v  w * (x  v))"
      by (simp add: while_def)
    have 3: "y * y * y * bot  y * w * xω"
      by (metis sup_commute sup_bot_left mult_assoc mult_left_sub_dist_sup_left star.circ_loop_fixpoint star.circ_transitive_equal)
    have "z * xω  y * y * z * xω  (y * n(yω) * L  w) * xω"
      using 1 by (metis mult_assoc mult_left_isotone mult_right_dist_sup omega_unfold)
    hence "z * xω  yω  y * y * n(yω) * L * xω  y * w * xω"
      by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup mult_right_dist_sup omega_induct star.left_plus_circ)
    also have "...  yω  y * y * n(yω) * L  y * w * xω"
      by (metis sup_left_isotone sup_right_isotone mult_assoc mult_right_isotone n_L_below_L)
    also have "... = yω  n(y * y * yω) * L  y * w * xω"
      using 3 by (smt sup_assoc sup_commute sup_relative_same_increasing n_mult_omega_L_star_zero)
    also have "... = yω  y * w * xω"
      by (metis mult_assoc omega_unfold star_mult_omega sup_commute le_iff_sup n_L_decreasing)
    finally have "n(z * xω) * L  n(yω) * L  n(y * w * xω) * L"
      by (metis mult_assoc mult_left_isotone mult_right_dist_sup n_dist_omega_star n_isotone)
    also have "...  n(yω) * L  y * (w * (n(xω) * L  x * bot))"
      by (smt sup_commute sup_right_isotone mult_assoc mult_left_dist_sup n_mult_omega_L_below_zero)
    also have "...  n(yω) * L  y * (w * (n(xω) * L  x * v))"
      by (metis sup_right_isotone mult_right_isotone bot_least)
    also have "...  n(yω) * L  y * (z * v  w * (n(xω) * L  x * v))"
      using mult_left_sub_dist_sup_right sup_right_isotone by auto
    finally have 4: "n(z * xω) * L  y  (z * v  w * (x  v))"
      using while_def by auto
    have "z * (x  v) = z * n(xω) * L  z * x * v"
      by (simp add: mult_left_dist_sup while_def mult_assoc)
    also have "... = n(z * xω) * L  z * x * v"
      by (metis sup_commute sup_relative_same_increasing mult_right_isotone n_mult_omega_L_star_zero bot_least)
    finally show "z * (x  v)  y  (z * v  w * (x  v))"
      using 2 4 by simp
  qed
qed

lemma while_top:
  "top  x = L  top * x"
  by (metis n_top_L star.circ_top star_omega_top while_def)

lemma while_one_top:
  "1  x = L  x"
  by (smt mult_left_one n_top_L omega_one star_one while_def)

lemma while_finite_associative:
  "xω = bot  (x  y) * z = x  (y * z)"
  by (metis sup_bot_left mult_assoc n_zero_L_zero while_def)

lemma while_while_one:
  "y  (x  1) = n(yω) * L  y * n(xω) * L  y * x"
  by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)

text ‹AACP Theorem 8.17›

subclass bounded_extended_binary_itering
proof unfold_locales
  fix w x y z
  have "w * (x  y * z) = n(w * n(xω) * L) * L  w * x * y * z"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_n_L_split_n_n_L_L while_def)
  also have "...  n((w * n(xω) * L)ω) * L  w * x * y * z"
    by (simp add: mult_L_omega)
  also have "...  n((w * (x  y))ω) * L  w * x * y * z"
    by (smt sup_left_isotone sup_ge1 mult_assoc mult_left_isotone mult_right_isotone n_isotone omega_isotone while_def)
  also have "...  n((w * (x  y))ω) * L  w * (x  y) * z"
    by (metis star_below_while mult_assoc mult_left_isotone mult_right_isotone sup_right_isotone)
  also have "...  n((w * (x  y))ω) * L  (w * (x  y)) * (w * (x  y) * z)"
    using sup.boundedI sup.cobounded1 while_def while_increasing by auto
  finally show "w * (x  y * z)  (w * (x  y))  (w * (x  y) * z)"
    using while_def by auto
qed

subclass extended_binary_itering_apx
  apply unfold_locales
  by (metis n_below_n_omega n_left_upper_bound n_n_L order_trans while_def)

lemma while_simulate_4_plus:
  assumes "y * x  x * (x  (1  y))"
    shows "y * x * x  x * (x  (1  y))"
proof -
  have "x * (x  (1  y)) = x * n(xω) * L  x * x * (1  y)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  also have "... = n(x * xω) * L  x * x * (1  y)"
    by (smt n_mult_omega_L_star_zero sup_relative_same_increasing sup_commute sup_bot_right mult_left_sub_dist_sup_right)
  finally have 1: "x * (x  (1  y)) = n(xω) * L  x * x  x * x * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "x * x * y * x  x * x * n(xω) * L  x * x * x * x  x * x * x * x * y"
    by (metis assms mult_assoc mult_right_isotone mult_left_dist_sup star_plus)
  also have "... = n(x * x * xω) * L  x * x * x * x  x * x * x * x * y"
    by (smt (z3) sup_commute n_mult_omega_L_star omega_unfold semiring.distrib_left star_plus mult_assoc)
  also have "... = n(xω) * L  x * x * x  x * x * x * y"
    using omega_unfold star.circ_plus_same star.circ_transitive_equal star_mult_omega mult_assoc by auto
  also have "...  n(xω) * L  x * x  x * x * y"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have 2: "x * x * y * x  n(xω) * L  x * x  x * x * y"
    .
  have "(n(xω) * L  x * x  x * x * y) * x  n(xω) * L  x * x * x  x * x * y * x"
    by (metis mult_right_dist_sup n_L_below_L mult_assoc mult_right_isotone sup_left_isotone)
  also have "...  n(xω) * L  x * x  x * x * y * x"
    by (smt sup_commute sup_left_isotone mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
  also have "...  n(xω) * L  x * x  x * x * y"
    using 2 by simp
  finally show ?thesis
    using 1 assms star_right_induct by force
qed

lemma while_simulate_4_omega:
  assumes "y * x  x * (x  (1  y))"
    shows "y * xω  xω"
proof -
  have "x * (x  (1  y)) = x * n(xω) * L  x * x * (1  y)"
    using mult_left_dist_sup while_def mult_assoc by auto
  also have "... = n(x * xω) * L  x * x * (1  y)"
    by (smt (z3) mult_1_right mult_left_sub_dist_sup_left n_mult_omega_L_star sup_commute sup_relative_same_increasing)
  finally have "x * (x  (1  y)) = n(xω) * L  x * x  x * x * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "y * xω  n(xω) * L * xω  x * x * xω  x * x * y * xω"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "...  x * x * (y * xω)  xω"
    by (metis sup_left_isotone mult_L_omega omega_sub_vector mult_assoc omega_unfold star_mult_omega n_L_decreasing le_iff_sup sup_commute)
  finally have "y * xω  (x * x)ω  (x * x) * xω"
    by (simp add: omega_induct sup_monoid.add_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

lemma while_square_1:
  "x  1 = (x * x)  (x  1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x  x  y  x  1  x"
  by (metis star_left_induct_mult sup_mono n_galois n_sub_nL while_def while_one_top)

lemma while_mult_L:
  "(x * L)  z = z  x * L"
  by (metis sup_bot_right mult_left_zero while_denest_5 while_one_top while_productstar while_sumstar)

lemma tarski_top_omega_below_2:
  "x * L  (x * L)  bot"
  by (simp add: while_mult_L)

lemma tarski_top_omega_2:
  "x * L = (x * L)  bot"
  by (simp add: while_mult_L)

(*
lemma while_sub_mult_one: "x * (1 ⋆ y) ≤ 1 ⋆ x" nitpick [expect=genuine,card=3] oops
lemma while_unfold_below: "x = z ⊔ y * x ⟶ x ≤ y ⋆ z" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (λx . y * x ⊔ z) (y ⋆ z)" nitpick [expect=genuine,card=2] oops
lemma while_denest_3: "(x ⋆ w) ⋆ xω = (x ⋆ w)ω" nitpick [expect=genuine,card=2] oops
lemma while_mult_top: "(x * top) ⋆ z = z ⊔ x * top" nitpick [expect=genuine,card=2] oops
lemma tarski_below_top_omega: "x ≤ (x * L)ω" nitpick [expect=genuine,card=2] oops
lemma tarski_mult_omega_omega: "(x * yω)ω = x * yω" nitpick [expect=genuine,card=3] oops
lemma tarski_below_top_omega_2: "x ≤ (x * L) ⋆ bot" nitpick [expect=genuine,card=2] oops
lemma "1 = (x * bot) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma tarski: "x = bot ∨ top * x * top = top" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ z = ((x ⋆ 1) * y) ⋆ ((x ⋆ 1) * z)" nitpick [expect=genuine,card=2] oops
lemma while_top_2: "top ⋆ z = top * z" nitpick [expect=genuine,card=2] oops
lemma while_mult_top_2: "(x * top) ⋆ z = z ⊔ x * top * z" nitpick [expect=genuine,card=2] oops
lemma while_one_mult: "(x ⋆ 1) * x = x ⋆ x" nitpick [expect=genuine,card=4] oops
lemma "(x ⋆ 1) * y = x ⋆ y" nitpick [expect=genuine,card=2] oops
lemma while_associative: "(x ⋆ y) * z = x ⋆ (y * z)" nitpick [expect=genuine,card=2] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (λx . x * y ⊔ z) (z * (y ⋆ 1))" nitpick [expect=genuine,card=4] oops
lemma "1 ⊔ x * bot = x ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "x = x * (x ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "x * (x ⋆ 1) = x ⋆ 1" nitpick [expect=genuine,card=2] oops
lemma "x ⋆ 1 = x ⋆ (1 ⋆ 1)" nitpick [expect=genuine,card=3] oops
lemma "(x ⊔ y) ⋆ 1 = (x ⋆ (y ⋆ 1)) ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "z ⊔ y * x = x ⟹ y ⋆ z ≤ x" nitpick [expect=genuine,card=2] oops
lemma "y * x = x ⟹ y ⋆ x ≤ x" nitpick [expect=genuine,card=2] oops
lemma "z ⊔ x * y = x ⟹ z * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * y = x ⟹ x * (y ⋆ 1) ≤ x" nitpick [expect=genuine,card=3] oops
lemma "x * z = z * y ⟹ x ⋆ z ≤ z * (y ⋆ 1)" nitpick [expect=genuine,card=2] oops

lemma while_unfold_below_1: "x = y * x ⟹ x ≤ y ⋆ 1" nitpick [expect=genuine,card=3] oops
lemma "xω ≤ xω * xω" oops
lemma tarski_omega_idempotent: "xωω = xω" oops
*)

end

class n_omega_algebra_binary_strict = n_omega_algebra_binary + circ +
  assumes L_left_zero: "L * x = L"
  assumes circ_def: "x = n(xω) * L  x"
begin

subclass strict_binary_itering
  apply unfold_locales
  apply (metis while_def mult_assoc L_left_zero mult_right_dist_sup)
  by (metis circ_def while_def mult_1_right)

end

end

Theory N_Relation_Algebras

(* Title:      N-Relation-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹N-Relation-Algebras›

theory N_Relation_Algebras

imports Stone_Relation_Algebras.Relation_Algebras N_Omega_Algebras

begin

context bounded_distrib_allegory
begin

subclass lattice_ordered_pre_left_semiring ..

end

text ‹Theorem 37›

sublocale relation_algebra < n_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top
  apply unfold_locales
  using N_comp_top comp_inf.semiring.distrib_left inf.sup_monoid.add_commute inf_vector_comp apply simp
  apply (metis N_comp compl_sup double_compl mult_assoc mult_right_dist_sup top_mult_top N_comp_N)
  apply (metis brouwer.p_antitone inf.sup_monoid.add_commute inf.sup_right_isotone mult_left_isotone p_antitone_sup)
  apply simp
  using N_vector_top apply force
  apply simp
  apply (simp add: brouwer.p_antitone_iff top_right_mult_increasing)
  apply simp
  apply (metis N_comp_top conv_complement_sub double_compl le_supI2 le_iff_sup mult_assoc mult_left_isotone schroeder_3)
  by simp

sublocale relation_algebra < n_algebra_apx where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq
  apply unfold_locales
  using n_less_eq_char by force

no_notation
  inverse_divide (infixl "'/" 70)

notation
  divide (infixl "'/" 70)

class left_residuated_relation_algebra = relation_algebra + inverse +
  assumes lres_def: "x / y = -(-x * yT)"
begin

text ‹Theorem 32.1›

subclass residuated_pre_left_semiring
  apply unfold_locales
  by (metis compl_le_swap1 lres_def schroeder_4)

end

context left_residuated_relation_algebra
begin

text ‹Theorem 32.3›

lemma lres_mult_lres_lres:
  "x / (z * y) = (x / y) / z"
  by (metis conv_dist_comp double_compl lres_def mult_assoc)

text ‹Theorem 32.5›

lemma lres_dist_inf:
  "(x  y) / z = (x / z)  (y / z)"
  by (metis compl_inf compl_sup lres_def mult_right_dist_sup)

text ‹Theorem 32.6›

lemma lres_add_export_vector:
  assumes "vector x"
    shows "(x  y) / z = x  (y / z)"
proof -
  have "(x  y) / z = -((-x  -y) * zT)"
    by (simp add: lres_def)
  also have "... = -(-x  (-y * zT))"
    using assms vector_complement_closed vector_inf_comp by auto
  also have "... = x  (y / z)"
    by (simp add: lres_def)
  finally show ?thesis
    .
qed

text ‹Theorem 32.7›

lemma lres_top_vector:
  "vector (x / top)"
  using equivalence_top_closed lres_def vector_complement_closed vector_mult_closed vector_top_closed by auto

text ‹Theorem 32.10›

lemma lres_top_export_inf_mult:
  "((x / top)  y) * z = (x / top)  (y * z)"
  by (simp add: vector_inf_comp lres_top_vector)

lemma N_lres:
  "N(x) = x / top  1"
  using lres_def by auto

end

class complete_relation_algebra = relation_algebra + complete_lattice
begin

definition mu :: "('a  'a)  'a" where "mu f  Inf { y . f y  y }"
definition nu :: "('a  'a)  'a" where "nu f  Sup { y . y  f y }"

lemma mu_lower_bound:
  "f x  x  mu f  x"
  by (auto simp add: mu_def intro: Inf_lower)

lemma mu_greatest_lower_bound:
  "(y . f y  y  x  y)  x  mu f"
  using lfp_def lfp_greatest mu_def by auto

lemma mu_unfold_1:
  "isotone f  f (mu f)  mu f"
  by (metis mu_greatest_lower_bound order_trans mu_lower_bound isotone_def)

lemma mu_unfold_2:
  "isotone f  mu f  f (mu f)"
  by (simp add: mu_lower_bound mu_unfold_1 ord.isotone_def)

lemma mu_unfold:
  "isotone f  mu f = f (mu f)"
  by (simp add: order.antisym mu_unfold_1 mu_unfold_2)

lemma mu_const:
  "mu (λx . y) = y"
  by (simp add: isotone_def mu_unfold)

lemma mu_lpfp:
  "isotone f  is_least_prefixpoint f (mu f)"
  by (simp add: is_least_prefixpoint_def mu_lower_bound mu_unfold_1)
  
lemma mu_lfp:
  "isotone f  is_least_fixpoint f (mu f)"
  by (metis is_least_fixpoint_def mu_lower_bound mu_unfold order_refl)

lemma mu_pmu:
  "isotone f   f = mu f"
  using least_prefixpoint_same mu_lpfp by force
  
lemma mu_mu:
  "isotone f  μ f = mu f"
  using least_fixpoint_same mu_lfp by fastforce
  
end

class omega_relation_algebra = relation_algebra + star + omega +
  assumes ra_star_left_unfold : "1  y * y  y"
  assumes ra_star_left_induct : "z  y * x  x  y * z  x"
  assumes ra_star_right_induct: "z  x * y  x  z * y  x"
  assumes ra_omega_unfold: "yω = y * yω"
  assumes ra_omega_induct: "x  z  y * x  x  yω  y * z"
begin

subclass bounded_omega_algebra
  apply unfold_locales
  using ra_star_left_unfold apply blast
  using ra_star_left_induct apply blast
  using ra_star_right_induct apply blast
  using ra_omega_unfold apply blast
  using ra_omega_induct by blast

end

text ‹Theorem 38›

sublocale omega_relation_algebra < n_omega_algebra where sup = sup and bot = bot and top = top and inf = inf and n = N and L = top and apx = greater_eq and Omega = "λx . N(xω) * top  x"
  apply unfold_locales
  apply simp
  using n_split_omega_mult omega_vector star_mult_omega apply force
  by simp

end

Theory Domain

(* Title:      Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain›

theory Domain

imports Stone_Relation_Algebras.Semirings Tests

begin

context idempotent_left_semiring
begin

sublocale ils: il_semiring where inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: sup_assoc)
  apply (simp add: sup_commute)
  apply simp
  apply simp
  apply (simp add: mult_assoc)
  apply (simp add: mult_right_dist_sup)
  apply simp
  apply simp
  apply simp
  apply (simp add: mult_right_isotone)
  apply (simp add: le_iff_sup)
  by (simp add: less_le_not_le)

end

class left_zero_domain_semiring = idempotent_left_zero_semiring + dom +
  assumes d_restrict: "x  d(x) * x = d(x) * x"
  assumes d_mult_d  : "d(x * y) = d(x * d(y))"
  assumes d_plus_one: "d(x)  1 = 1"
  assumes d_zero    : "d(bot) = bot"
  assumes d_dist_sup: "d(x  y) = d(x)  d(y)"
begin

text ‹Many lemmas in this class are taken from Georg Struth's theories.›

lemma d_restrict_equals:
  "x = d(x) * x"
  by (metis sup_commute d_plus_one d_restrict mult_left_one mult_right_dist_sup)

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(y . x = d(y))  x = d(x)"
  using d_involutive by auto

lemma d_type:
  "P . (x . x = d(x)  P(x))  (x . P(d(x)))"
  by (metis d_involutive)

lemma d_mult_sub:
  "d(x * y)  d(x)"
  by (metis d_dist_sup d_mult_d d_plus_one le_iff_sup mult_left_sub_dist_sup_left mult_1_right)

lemma d_sub_one:
  "x  1  x  d(x)"
  by (metis d_restrict_equals mult_right_isotone mult_1_right)

lemma d_strict:
  "d(x) = bot  x = bot"
  by (metis d_restrict_equals d_zero mult_left_zero)

lemma d_one:
  "d(1) = 1"
  by (metis d_restrict_equals mult_1_right)

lemma d_below_one:
  "d(x)  1"
  by (simp add: d_plus_one le_iff_sup)

lemma d_isotone:
  "x  y  d(x)  d(y)"
  by (metis d_dist_sup le_iff_sup)

lemma d_plus_left_upper_bound:
  "d(x)  d(x  y)"
  by (simp add: d_isotone)

lemma d_export:
  "d(d(x) * y) = d(x) * d(y)"
  apply (rule order.antisym)
  apply (metis d_below_one d_involutive d_mult_sub d_restrict_equals d_isotone d_mult_d mult_isotone mult_left_one)
  by (metis d_below_one d_sub_one coreflexive_mult_closed d_mult_d)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (metis d_export d_restrict_equals)

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis ils.il_inf_associative order.antisym d_export d_mult_d d_mult_sub d_one d_restrict_equals mult_isotone mult_left_one)

lemma d_least_left_preserver:
  "x  d(y) * x  d(x)  d(y)"
  by (metis d_below_one d_involutive d_mult_sub d_restrict_equals order.eq_iff mult_left_isotone mult_left_one)

lemma d_weak_locality:
  "x * y = bot  x * d(y) = bot"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x)  d(y)) = d(x)  d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y)  d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_greatest_lower_bound:
  "d(x)  d(y) * d(z)  d(x)  d(y)  d(x)  d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x)  d(y)) = d(x)"
  by (metis sup_commute d_idempotent d_plus_one mult_left_dist_sup mult_1_right)

lemma d_sup_left_absorb_mult:
  "d(x)  d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_sup_left_dist_mult:
  "d(x)  d(y) * d(z) = (d(x)  d(y)) * (d(x)  d(z))"
  by (smt sup_assoc d_commutative d_idempotent d_mult_left_absorb_sup mult_left_dist_sup mult_right_dist_sup)

lemma d_order:
  "d(x)  d(y)  d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

lemma d_mult_below:
  "d(x) * y  y"
  by (metis sup_left_divisibility d_plus_one mult_left_one mult_right_dist_sup)

lemma d_preserves_equation:
  "d(y) * x  x * d(y)  d(y) * x = d(y) * x * d(y)"
  by (simp add: d_below_one d_idempotent test_preserves_equation)

end

class left_zero_antidomain_semiring = idempotent_left_zero_semiring + dom + uminus +
  assumes a_restrict   : "-x * x = bot"
  assumes a_plus_mult_d: "-(x * y)  -(x * --y) = -(x * --y)"
  assumes a_complement : "--x  -x = 1"
  assumes d_def        : "d(x) = --x"
begin

sublocale aa: a_algebra where minus = "λx y . -(-x  y)" and uminus = uminus and inf = times and sup = sup and bot = bot and less_eq = less_eq and less = less and top = 1
  apply unfold_locales
  apply (simp add: a_restrict)
  using a_complement sup_commute apply fastforce
  apply (simp add: a_plus_mult_d le_iff_sup)
  by simp

subclass left_zero_domain_semiring
  apply unfold_locales
  apply (simp add: d_def aa.double_complement_above)
  apply (simp add: aa.a_d.d3_eq d_def)
  apply (simp add: d_def)
  apply (simp add: d_def)
  by (simp add: d_def aa.l15)

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: aa.sba_dual.sub_commutative)
  apply (simp add: aa.sba_dual.sub_complement)
  using aa.sba_dual.sub_sup_closed apply simp
  apply simp
  apply simp
  apply (simp add: aa.sba_dual.sub_inf_def)
  apply (simp add: aa.less_eq_inf)
  by (simp add: less_le_not_le)

text ‹Many lemmas in this class are taken from Georg Struth's theories.›

notation
  uminus ("a")

lemma a_greatest_left_absorber:
  "a(x) * y = bot  a(x)  a(y)"
  by (simp add: aa.l10_iff)

lemma a_mult_d:
  "a(x * y) = a(x * d(y))"
  by (simp add: d_def aa.sba3_complement_inf_double_complement)

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (simp add: d_def)

lemma a_plus_left_lower_bound:
  "a(x  y)  a(x)"
  by (simp add: aa.l9)

lemma a_mult_sup:
  "a(x) * (y  x) = a(x) * y"
  by (simp add: aa.sba3_inf_complement_bot semiring.distrib_left)

lemma a_3:
  "a(x) * a(y) * d(x  y) = bot"
  using d_weak_locality aa.l12 aa.sba3_inf_complement_bot by force

lemma a_export:
  "a(a(x) * y) = d(x)  a(y)"
  using a_mult_d d_def aa.sba_dual.sub_inf_def by auto

lemma a_fixpoint:
  "x . (a(x) = x  (y . y = bot))"
  by (metis aa.a_d.d_fully_strict aa.sba2_bot_unit aa.sup_idempotent aa.sup_right_zero_var)

lemma a_strict:
  "a(x) = 1  x = bot"
  using aa.a_d.d_fully_strict one_def by fastforce

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: aa.sba3_inf_complement_bot d_def)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot  a(x)  a(y)"
  by (simp add: aa.less_eq_inf_bot d_def)

lemma a_antitone:
  "x  y  a(y)  a(x)"
  by (simp add: aa.l9)

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x  y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x)  d(y)"
  by (simp add: a_export d_def)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x)  a(y)"
  by (simp add: d_def sup_def)

lemma a_plus_deMorgan:
  "a(a(x)  a(y)) = d(x) * d(y)"
  by (simp add: aa.sub_sup_demorgan d_def)

lemma a_plus_deMorgan_1:
  "a(d(x)  d(y)) = a(x) * a(y)"
  by (simp add: aa.sup_demorgan d_def)

lemma a_mult_left_upper_bound:
  "a(x)  a(x * y)"
  using aa.l5 d_def d_mult_sub by auto

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x)  a(y)"
  using a_mult_d a_mult_deMorgan_2 by auto

lemma a_7:
  "d(x) * a(d(y)  d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y)  d(z)  d(x)  d(z)  d(y)"
  using aa.sba_dual.shunting_right d_def by auto

lemma d_d_shunting:
  "d(x) * d(y)  d(z)  d(x)  d(z)  a(y)"
  using d_a_shunting d_def by auto

lemma d_cancellation_1:
  "d(x)  d(y)  (d(x) * a(y))"
  by (metis a_d_closed aa.sba2_export aa.sup_demorgan d_def eq_refl le_supE sup_commute)

lemma d_cancellation_2:
  "(d(z)  d(y)) * a(y)  d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x)  a(y)) = a(x)  a(y)"
  using aa.sub_sup_closed d_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using a_d_closed aa.l12 by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot  d(x)  d(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot  d(x)  a(y)"
  by (simp add: aa.l10_iff d_def)

lemma d_compl_intro:
  "d(x)  d(y) = d(x)  a(x) * d(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma a_compl_intro:
  "a(x)  a(y) = a(x)  d(x) * a(y)"
  by (simp add: aa.sup_complement_intro d_def)

lemma kat_2:
  "y * a(z)  a(x) * y  d(x) * y * a(z) = bot"
  by (smt a_export a_plus_left_lower_bound le_sup_iff d_d_shunting_zero d_export d_strict le_iff_sup mult_assoc)

lemma kat_3:
  "d(x) * y * a(z) = bot  d(x) * y = d(x) * y * d(z)"
  by (metis a_export_d aa.complement_bot d_complement_zero d_def mult_1_right mult_left_dist_sup sup_bot_left)

lemma kat_4:
  "d(x) * y = d(x) * y * d(z)  d(x) * y  y * d(z)"
  using d_mult_below mult_assoc by auto

lemma kat_2_equiv:
  "y * a(z)  a(x) * y  d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (metis aa.top_greatest a_complement sup_bot_left d_def mult_left_one mult_right_dist_sup mult_right_isotone mult_1_right)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z)  d(x) * y  y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent le_iff_sup mult_assoc mult_left_dist_sup)
  by (metis d_plus_one le_iff_sup mult_left_dist_sup mult_1_right)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot  y * d(x) = d(z) * y * d(x)"
  by (metis a_complement a_restrict sup_bot_left d_a_closed d_def mult_assoc mult_left_one mult_left_zero mult_right_dist_sup)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x)  y * d(x)  d(z) * y"
  using kat_2_equiv kat_3_equiv_opp d_def by auto

lemma d_restrict_iff:
  "(x  y)  (x  d(x) * y)"
  by (metis d_mult_below d_restrict_equals mult_isotone order_lesseq_imp)

lemma d_restrict_iff_1:
  "(d(x) * y  z)  (d(x) * y  d(x) * z)"
  by (metis sup_commute d_export d_mult_left_lower_bound d_plus_one d_restrict_iff mult_left_isotone mult_left_one mult_right_sub_dist_sup_right order_trans)

end

end

Theory Domain_Iterings

(* Title:      Domain Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain Iterings›

theory Domain_Iterings

imports Domain Lattice_Ordered_Semirings Omega_Algebras

begin

class domain_semiring_lattice = left_zero_domain_semiring + lattice_ordered_pre_left_semiring
begin

subclass bounded_idempotent_left_zero_semiring ..

lemma d_top:
  "d(top) = 1"
  by (metis sup_left_top d_dist_sup d_one d_plus_one)

lemma mult_domain_top:
  "x * d(y) * top  d(x * y) * top"
  by (smt d_mult_d d_restrict_equals mult_assoc mult_right_isotone top_greatest)

lemma domain_meet_domain:
  "d(x  d(y) * z)  d(y)"
  by (metis d_export d_isotone d_mult_greatest_lower_bound inf.cobounded2)

lemma meet_domain:
  "x  d(y) * z = d(y) * (x  z)"
  apply (rule order.antisym)
  apply (metis domain_meet_domain d_mult_below d_restrict_equals inf_mono mult_isotone)
  by (meson d_mult_below le_inf_iff mult_left_sub_dist_inf_right)

lemma meet_intro_domain:
  "x  y = d(y) * x  y"
  by (metis d_restrict_equals inf_commute meet_domain)

lemma meet_domain_top:
  "x  d(y) * top = d(y) * x"
  by (simp add: meet_domain)

(*
lemma "d(x) = x * top ⊓ 1" nitpick [expect=genuine,card=3] oops
*)

lemma d_galois:
  "d(x)  d(y)  x  d(y) * top"
  by (metis d_export d_isotone d_mult_left_absorb_sup d_plus_one d_restrict_equals d_top mult_isotone top.extremum)

lemma vector_meet:
  "x * top  y  d(x) * y"
  by (metis d_galois d_mult_sub inf.sup_monoid.add_commute inf.sup_right_isotone meet_domain_top)

end

class domain_semiring_lattice_L = domain_semiring_lattice + L +
  assumes l1: "x * L = x * bot  d(x) * L"
  assumes l2: "d(L) * x  x * d(L)"
  assumes l3: "d(L) * top  L  d(L * bot) * top"
  assumes l4: "L * top  L"
  assumes l5: "x * bot  L  (x  L) * bot"
begin

lemma l8:
  "(x  L) * bot  x * bot  L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

lemma l9:
  "x * bot  L  d(x * bot) * L"
  by (metis vector_meet vector_mult_closed zero_vector)

lemma l10:
  "L * L = L"
  by (metis d_restrict_equals l1 le_iff_sup zero_right_mult_decreasing)

lemma l11:
  "d(x) * L  x * L"
  by (metis l1 sup.cobounded2)

lemma l12:
  "d(x * bot) * L  x * bot"
  by (metis sup_right_divisibility l1 mult_assoc mult_left_zero)

lemma l13:
  "d(x * bot) * L  x"
  using l12 order_trans zero_right_mult_decreasing by blast

lemma l14:
  "x * L  x * bot  L"
  by (metis d_mult_below l1 sup_right_isotone)

lemma l15:
  "x * d(y) * L = x * bot  d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero l1 mult_assoc mult_left_zero)

lemma l16:
  "x * top  L  x * L"
  using inf.order_lesseq_imp l11 vector_meet by blast

lemma l17:
  "d(x) * L  d(x * L) * L"
  by (metis d_mult_below l11 le_infE le_infI meet_intro_domain)

lemma l18:
  "d(x) * L = d(x * L) * L"
  by (simp add: order.antisym d_mult_sub l17 mult_left_isotone)

lemma l19:
  "d(x * top * bot) * L  d(x * L) * L"
  by (metis d_mult_sub l18 mult_assoc mult_left_isotone)

lemma l20:
  "x  y  x  y  L  x  y  d(y * bot) * top"
  apply (rule iffI)
  apply (simp add: le_supI1)
  by (smt sup_commute sup_inf_distrib1 l13 le_iff_sup meet_domain_top)

lemma l21:
  "d(x * bot) * L  x * bot  L"
  by (simp add: d_mult_below l12)

lemma l22:
  "x * bot  L = d(x * bot) * L"
  using l21 order.antisym l9 by auto

lemma l23:
  "x * top  L = d(x) * L"
  apply (rule order.antisym)
  apply (simp add: vector_meet)
  by (metis d_mult_below inf.le_sup_iff inf_top.left_neutral l1 le_supE mult_left_sub_dist_inf_left)

lemma l29:
  "L * d(L) = L"
  by (metis d_preserves_equation d_restrict_equals l2)

lemma l30:
  "d(L) * x  (x  L)  d(L * bot) * x"
  by (metis inf.sup_right_divisibility inf_left_commute inf_sup_distrib1 l3 meet_domain_top)

lemma l31:
  "d(L) * x = (x  L)  d(L * bot) * x"
  by (smt (z3) l30 d_dist_sup le_iff_sup meet_intro_domain semiring.combine_common_factor sup_commute sup_inf_absorb zero_right_mult_decreasing)

lemma l40:
  "L * x  L"
  by (meson bot_least inf.order_trans l4 semiring.mult_left_mono top.extremum)

lemma l41:
  "L * top = L"
  by (simp add: l40 order.antisym top_right_mult_increasing)

lemma l50:
  "x * bot  L = (x  L) * bot"
  using order.antisym l5 l8 by force

lemma l51:
  "d(x * bot) * L = (x  L) * bot"
  using l22 l50 by auto

lemma l90:
  "L * top * L = L"
  by (simp add: l41 l10)

lemma l91:
  assumes "x = x * top"
    shows "d(L * bot) * x  d(x * bot) * top"
proof -
  have "d(L * bot) * x  d(d(L * bot) * x) * top"
    using d_galois by blast
  also have "... = d(d(L * bot) * d(x)) * top"
    using d_mult_d by auto
  also have "... = d(d(x) * L * bot) * top"
    using d_commutative d_mult_d ils.il_inf_associative by auto
  also have "...  d(x * L * bot) * top"
    by (metis d_isotone l11 mult_left_isotone)
  also have "...  d(x * top * bot) * top"
    by (simp add: d_isotone mult_left_isotone mult_right_isotone)
  finally show ?thesis
    using assms by auto
qed

lemma l92:
  assumes "x = x * top"
    shows "d(L * bot) * x  d((x  L) * bot) * top"
proof -
  have "d(L * bot) * x = d(L) * d(L * bot) * x"
    using d_commutative d_mult_sub d_order by auto
  also have "...  d(L) * d(x * bot) * top"
    by (metis assms order.eq_iff l91 mult_assoc mult_isotone)
  also have "... = d(d(x * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "...  d((x  L) * bot) * top"
    by (simp add: l51)
  finally show ?thesis
    .
qed

end

class domain_itering_lattice_L = bounded_itering + domain_semiring_lattice_L
begin

lemma mult_L_circ:
  "(x * L) = 1  x * L"
  by (metis circ_back_loop_fixpoint circ_mult l40 le_iff_sup mult_assoc)

lemma mult_L_circ_mult_below:
  "(x * L) * y  y  x * L"
  by (smt sup_right_isotone l40 mult_L_circ mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone)

lemma circ_L:
  "L = L  1"
  by (metis sup_commute l10 mult_L_circ)

lemma circ_d0_L:
  "x * d(x * bot) * L = x * bot"
  by (metis sup_bot_right circ_loop_fixpoint circ_plus_same d_zero l15 mult_assoc mult_left_zero)

lemma d0_circ_left_unfold:
  "d(x * bot) = d(x * x * bot)"
  by (metis sup_commute sup_bot_left circ_loop_fixpoint mult_assoc)

lemma d_circ_import:
  "d(y) * x  x * d(y)  d(y) * x = d(y) * (d(y) * x)"
  apply (rule order.antisym)
  apply (simp add: circ_import d_idempotent d_plus_one le_iff_sup)
  using circ_isotone d_mult_below mult_right_isotone by auto

end

class domain_omega_algebra_lattice_L = bounded_left_zero_omega_algebra + domain_semiring_lattice_L
begin

lemma mult_L_star:
  "(x * L) = 1  x * L"
  by (metis l40 le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_mult)

lemma mult_L_omega:
  "(x * L)ω  x * L"
  by (metis l40 mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L  y) = y  y * x * L"
proof (rule order.antisym)
  have "(x * L  y) * (y  y * x * L) = x * L * (y  y * x * L)  y * (y  y * x * L)"
    by (simp add: mult_right_dist_sup)
  also have "...  x * L  y * (y  y * x * L)"
    by (metis sup_left_isotone l40 mult_assoc mult_right_isotone)
  also have "...  x * L  y * y  y * x * L"
    by (smt sup_assoc sup_commute sup_ge2 mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "...  x * L  y  y * x * L"
    by (meson order_refl star.left_plus_below_circ sup_mono)
  also have "... = y  y * x * L"
    by (metis sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star.circ_reflexive star.circ_sup_one_right_unfold star_involutive)
  finally have "1  (x * L  y) * (y  y * x * L)  y  y * x * L"
    by (meson le_supI le_supI1 star.circ_reflexive)
  thus "(x * L  y)  y  y * x * L"
    using star_left_induct by fastforce
next
  show "y  y * x * L  (x * L  y)"
    by (metis sup_commute le_sup_iff mult_assoc star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
qed

lemma mult_L_sup_omega:
  "(x * L  y)ω  yω  y * x * L"
proof -
  have 1: "(y * x * L)ω  yω  y * x * L"
    by (simp add: le_supI2 mult_L_omega)
  have "(y * x * L) * yω  yω  y * x * L"
    by (metis sup_right_isotone l40 mult_assoc mult_right_isotone star_left_induct)
  thus ?thesis
    using 1 by (simp add: ils.il_inf_associative omega_decompose sup_monoid.add_commute)
qed

end

sublocale domain_omega_algebra_lattice_L < dL_star: itering where circ = star ..

sublocale domain_omega_algebra_lattice_L < dL_star: domain_itering_lattice_L where circ = star ..

context domain_omega_algebra_lattice_L
begin

lemma d0_star_below_d0_omega:
  "d(x * bot)  d(xω * bot)"
  by (simp add: d_isotone star_bot_below_omega_bot)

lemma d0_below_d0_omega:
  "d(x * bot)  d(xω * bot)"
  by (metis d0_star_below_d0_omega d_isotone mult_left_isotone order_trans star.circ_increasing)

lemma star_L_split:
  assumes "y  z"
      and "x * z * L  x * bot  z * L"
    shows "x * y * L  x * bot  z * L"
proof -
  have "x * (x * bot  z * L)  x * bot  x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "...  x * bot  x * bot  z * L"
    using assms(2) semiring.add_left_mono sup_monoid.add_assoc by auto
  also have "... = x * bot  z * L"
    using mult_isotone star.circ_increasing sup.absorb_iff1 by force
  finally have "y * L  x * (x * bot  z * L)  x * bot  z * L"
    by (simp add: assms(1) le_supI1 mult_left_isotone sup_monoid.add_commute)
  thus ?thesis
    by (simp add: star_left_induct mult.assoc)
qed

lemma star_L_split_same:
  "x * y * L  x * bot  y * L  x * y * L = x * bot  y * L"
  apply (rule order.antisym)
  using star_L_split apply blast
  by (metis bot_least ils.il_inf_associative le_supI mult_isotone mult_left_one order_refl star.circ_reflexive)

lemma star_d_L_split_equal:
  "d(x * y)  d(y)  x * d(y) * L = x * bot  d(y) * L"
  by (metis sup_right_isotone l15 le_iff_sup mult_right_sub_dist_sup_left star_L_split_same)

lemma d0_omega_mult:
  "d(xω * y * bot) = d(xω * bot)"
  apply (rule order.antisym)
  apply (simp add: d_isotone mult_isotone omega_sub_vector)
  by (metis d_isotone mult_assoc mult_right_isotone bot_least)

lemma d_omega_export:
  "d(y) * x  x * d(y)  d(y) * xω = (d(y) * x)ω"
  apply (rule order.antisym)
  apply (simp add: d_preserves_equation omega_simulation)
  by (smt le_iff_sup mult_left_dist_sup omega_simulation_2 omega_slide)

lemma d_omega_import:
  "d(y) * x  x * d(y)  d(y) * xω = d(y) * (d(y) * x)ω"
  using d_idempotent omega_import order.refl by auto

lemma star_d_omega_top:
  "x * d(xω) * top = x * bot  d(xω) * top"
  apply (rule order.antisym)
  apply (metis le_supI2 mult_domain_top star_mult_omega)
  by (metis ils.il_inf_associative le_supI mult_left_one mult_left_sub_dist_sup_right mult_right_sub_dist_sup_left star.circ_right_unfold_1 sup_monoid.add_0_right)

lemma omega_meet_L:
  "xω  L = d(xω) * L"
  by (metis l23 omega_vector)

(*
lemma d_star_mult: "d(x * y) ≤ d(y) ⟹ d(x * y) = d(x * bot) ⊔ d(y)" oops
lemma d0_split_omega_omega: "xω ≤ xω * bot ⊔ d(xω ⊓ L) * top" nitpick [expect=genuine,card=2] oops
*)

end

end

Theory Domain_Recursion

(* Title:      Domain Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Domain Recursion›

theory Domain_Recursion

imports Domain_Iterings Approximation

begin

class domain_semiring_lattice_apx = domain_semiring_lattice_L + apx +
  assumes apx_def: "x  y  x  y  L  d(L) * y  x  d(x * bot) * top"
begin

lemma apx_transitive:
  assumes "x  y"
      and "y  z"
    shows "x  z"
proof -
  have 1: "x  z  L"
    by (smt assms sup_assoc sup_commute apx_def le_iff_sup)
  have "d(d(L) * y * bot) * top  d((x  d(x * bot) * top) * bot) * top"
    by (metis assms(1) apx_def d_isotone mult_left_isotone)
  also have "...  d(x * bot) * top"
    by (metis le_sup_iff d_galois mult_left_isotone mult_right_dist_sup order_refl zero_right_mult_decreasing)
  finally have 2: "d(d(L) * y * bot) * top  d(x * bot) * top"
    .
  have "d(L) * z = d(L) * (d(L) * z)"
    by (simp add: d_idempotent ils.il_inf_associative)
  also have "...  d(L) * y  d(d(L) * y * bot) * top"
    by (metis assms(2) apx_def d_export mult_assoc mult_left_dist_sup mult_right_isotone)
  also have "...  x  d(x * bot) * top"
    using 2 by (meson assms(1) apx_def le_supI2 sup_least)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

lemma apx_meet_L:
  assumes "y  x"
    shows "x  L  y  L"
proof -
  have "x  L = d(L) * x  L"
    using meet_intro_domain by auto
  also have "...  (y  d(y * bot) * top)  L"
    using assms apx_def inf.sup_left_isotone by blast
  also have "...  y"
    by (simp add: inf.sup_monoid.add_commute inf_sup_distrib1 l13 meet_domain_top)
  finally show ?thesis
    by simp
qed

lemma sup_apx_left_isotone:
  assumes "x  y"
    shows "x  z  y  z"
proof -
  have 1: "x  z  y  z  L"
    by (smt assms sup_assoc sup_commute sup_left_isotone apx_def)
  have "d(L) * (y  z) = d(L) * y  d(L) * z"
    by (simp add: mult_left_dist_sup)
  also have "...  d(L) * y  z"
    by (simp add: d_mult_below le_supI1 sup_commute)
  also have "...  x  d(x * bot) * top  z"
    using assms apx_def sup_left_isotone by blast
  also have "...  x  z  d((x  z) * bot) * top"
    by (simp add: d_dist_sup le_iff_sup semiring.distrib_right sup.left_commute sup_monoid.add_assoc)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

subclass apx_biorder
  apply unfold_locales
  apply (metis le_sup_iff sup_ge1 apx_def d_plus_one mult_left_one mult_right_dist_sup)
  apply (meson apx_meet_L order.antisym apx_def relative_equality sup_same_context)
  using apx_transitive by blast

lemma mult_apx_left_isotone:
  assumes "x  y"
    shows "x * z  y * z"
proof -
  have "x * z  y * z  L * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence 1: "x * z  y * z  L"
    using l40 order_lesseq_imp semiring.add_left_mono by blast
  have "d(L) * y * z  x * z  d(x * bot) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  also have "...  x * z  d(x * z * bot) * top"
    by (metis sup_right_isotone d_isotone mult_assoc mult_isotone mult_right_isotone top_greatest bot_least)
  finally show ?thesis
    using 1 by (simp add: apx_def mult_assoc)
qed

lemma mult_apx_right_isotone:
  assumes "x  y"
    shows "z * x  z * y"
proof -
  have "z * x  z * y  z * L"
    by (metis assms apx_def mult_left_dist_sup mult_right_isotone)
  also have "...  z * y  z * bot  L"
    using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
  finally have 1: "z * x  z * y  L"
    using mult_right_isotone sup.order_iff by auto
  have "d(L) * z * y  z * d(L) * y"
    by (simp add: l2 mult_left_isotone)
  also have "...  z * (x  d(x * bot) * top)"
    by (metis assms apx_def mult_assoc mult_right_isotone)
  also have "... = z * x  z * d(x * bot) * top"
    by (simp add: mult_left_dist_sup mult_assoc)
  also have "...  z * x  d(z * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  finally show ?thesis
    using 1 by (simp add: apx_def mult_assoc)
qed

subclass apx_semiring
  apply unfold_locales
  apply (metis sup_ge2 apx_def l3 mult_right_isotone order_trans top_greatest)
  apply (simp add: sup_apx_left_isotone)
  apply (simp add: mult_apx_left_isotone)
  by (simp add: mult_apx_right_isotone)

lemma meet_L_apx_isotone:
  "x  y  x  L  y  L"
  by (smt (z3) inf.cobounded2 sup.coboundedI1 sup_absorb sup_commute apx_def apx_meet_L d_restrict_equals l20 inf_commute meet_domain)

definition kappa_apx_meet :: "('a  'a)  bool"
  where "kappa_apx_meet f  apx.has_least_fixpoint f  has_apx_meet (μ f) (ν f)  κ f = μ f  ν f"

definition kappa_mu_nu :: "('a  'a)  bool"
  where "kappa_mu_nu f  apx.has_least_fixpoint f  κ f = μ f  (ν f  L)"

definition nu_below_mu_nu :: "('a  'a)  bool"
  where "nu_below_mu_nu f  d(L) * ν f  μ f  (ν f  L)  d(ν f * bot) * top"

definition nu_below_mu_nu_2 :: "('a  'a)  bool"
  where "nu_below_mu_nu_2 f  d(L) * ν f  μ f  (ν f  L)  d((μ f  (ν f  L)) * bot) * top"

definition mu_nu_apx_nu :: "('a  'a)  bool"
  where "mu_nu_apx_nu f  μ f  (ν f  L)  ν f"

definition mu_nu_apx_meet :: "('a  'a)  bool"
  where "mu_nu_apx_meet f  has_apx_meet (μ f) (ν f)  μ f  ν f = μ f  (ν f  L)"

definition apx_meet_below_nu :: "('a  'a)  bool"
  where "apx_meet_below_nu f  has_apx_meet (μ f) (ν f)  μ f  ν f  ν f"

lemma mu_below_l:
  "μ f  μ f  (ν f  L)"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  μ f  (ν f  L)  ν f"
  by (simp add: mu_below_nu)

lemma n_l_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  (μ f  (ν f  L))  L = ν f  L"
  by (meson l_below_nu inf.sup_same_context inf_le1 order_trans sup.cobounded2)

lemma l_apx_mu:
  "μ f  (ν f  L)  μ f"
  by (simp add: apx_def d_mult_below le_supI1 sup_inf_distrib1)

lemma nu_below_mu_nu_nu_below_mu_nu_2:
  assumes "nu_below_mu_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  have "d(L) * ν f = d(L) * (d(L) * ν f)"
    by (simp add: d_idempotent ils.il_inf_associative)
  also have "...  d(L) * (μ f  (ν f  L)  d(ν f * bot) * top)"
    using assms mult_isotone nu_below_mu_nu_def by blast
  also have "... = d(L) * (μ f  (ν f  L))  d(L) * d(ν f * bot) * top"
    by (simp add: ils.il_inf_associative mult_left_dist_sup)
  also have "...  μ f  (ν f  L)  d(L) * d(ν f * bot) * top"
    using d_mult_below sup_left_isotone by auto
  also have "... = μ f  (ν f  L)  d(d(ν f * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "... = μ f  (ν f  L)  d((ν f  L) * bot) * top"
    using l51 by auto
  also have "...  μ f  (ν f  L)  d((μ f  (ν f  L)) * bot) * top"
    by (meson d_isotone inf.eq_refl mult_isotone semiring.add_left_mono sup.cobounded2)
  finally show ?thesis
    using nu_below_mu_nu_2_def by auto
qed

lemma nu_below_mu_nu_2_nu_below_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "nu_below_mu_nu f"
proof -
  have "d(L) * ν f  μ f  (ν f  L)  d((μ f  (ν f  L)) * bot) * top"
    using assms(3) nu_below_mu_nu_2_def by blast
  also have "...  μ f  (ν f  L)  d(ν f * bot) * top"
    by (metis assms(1,2) d_isotone inf.sup_monoid.add_commute inf.sup_right_divisibility le_supI le_supI2 mu_below_nu mult_left_isotone sup_left_divisibility)
  finally show ?thesis
    by (simp add: nu_below_mu_nu_def)
qed

lemma nu_below_mu_nu_equivalent:
  "has_least_fixpoint f  has_greatest_fixpoint f  (nu_below_mu_nu f  nu_below_mu_nu_2 f)"
  using nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

lemma nu_below_mu_nu_2_mu_nu_apx_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "nu_below_mu_nu_2 f"
    shows "mu_nu_apx_nu f"
proof -
  have "μ f  (ν f  L)  ν f  L"
    using assms(1,2) l_below_nu le_supI1 by blast
  thus ?thesis
    using assms(3) apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def by blast
qed

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "μ f  (ν f  L)"
  have "is_apx_meet (μ f) (ν f) ?l"
    apply (unfold is_apx_meet_def, intro conjI)
    apply (simp add: l_apx_mu)
    using assms mu_nu_apx_nu_def apply blast
    by (metis apx_meet_L le_supI2 sup.order_iff sup_apx_left_isotone sup_inf_absorb)
  thus ?thesis
    by (smt apx_meet_char mu_nu_apx_meet_def)
qed

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  mu_nu_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

lemma apx_meet_below_nu_nu_below_mu_nu_2:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu_2 f"
proof -
  let ?l = "μ f  (ν f  L)"
  have "m . m  μ f  m  ν f  m  ν f  d(L) * ν f  ?l  d(?l * bot) * top"
  proof
    fix m
    show "m  μ f  m  ν f  m  ν f  d(L) * ν f  ?l  d(?l * bot) * top"
    proof
      assume 1: "m  μ f  m  ν f  m  ν f"
      hence "m  ?l"
        by (metis apx_def ils.il_associative sup.orderE sup.orderI sup_inf_distrib1 sup_inf_distrib2)
      hence "m  d(m * bot) * top  ?l  d(?l * bot) * top"
        by (meson d_isotone order.trans le_supI le_supI2 mult_left_isotone sup.cobounded1)
      thus "d(L) * ν f  ?l  d(?l * bot) * top"
        using 1 apx_def order_lesseq_imp by blast
    qed
  qed
  thus ?thesis
    by (smt (verit) assms apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have 1: "w . w  μ f  w  ν f  d(L) * κ f  w  d(w * bot) * top"
    by (metis assms(2,3) apx_def mult_right_isotone order_trans kappa_below_nu)
  have "w . w  μ f  w  ν f  w  κ f  L"
    by (metis assms(1,3) sup_left_isotone apx_def mu_below_kappa order_trans)
  hence "w . w  μ f  w  ν f  w  κ f"
    using 1 apx_def by blast
  hence "is_apx_meet (μ f) (ν f) (κ f)"
    using assms apx_meet_char is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu kappa_apx_meet_def by presburger
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f  kappa_apx_meet f  apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "μ f  (ν f  L)"
  let ?m = "μ f  ν f"
  have 1: "?m = ?l"
    by (metis assms(1,2,5) apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
  have 2: "?l  f(?l)  L"
  proof -
    have "?l  μ f  L"
      using sup_right_isotone by auto
    also have "... = f(μ f)  L"
      by (simp add: assms(1) mu_unfold)
    also have "...  f(?l)  L"
      by (metis assms(3) sup_left_isotone sup_ge1 isotone_def)
    finally show ?thesis
      .
  qed
  have "d(L) * f(?l)  ?l  d(?l * bot) * top"
  proof -
    have "d(L) * f(?l)  d(L) * f(ν f)"
      by (metis assms(1-3) l_below_nu mult_right_isotone ord.isotone_def)
    also have "... = d(L) * ν f"
      by (metis assms(2) nu_unfold)
    also have "...  ?l  d(?l * bot) * top"
      using apx_meet_below_nu_nu_below_mu_nu_2 assms(5) nu_below_mu_nu_2_def by blast
    finally show ?thesis
      .
  qed
  hence 3: "?l  f(?l)"
    using 2 by (simp add: apx_def)
  have 4: "f(?l)  μ f"
  proof -
    have "?l  μ f"
      by (simp add: l_apx_mu)
    thus ?thesis
      by (metis assms(1,4) mu_unfold ord.isotone_def)
  qed
  have 5: "f(?l)  ν f"
  proof -
    have "?l  ν f"
      by (meson apx_meet_below_nu_nu_below_mu_nu_2 assms(1,2,5) l_below_nu apx_def le_supI1 nu_below_mu_nu_2_def)
    thus ?thesis
      by (metis assms(2,4) nu_unfold ord.isotone_def)
  qed
  hence "f(?l)  ?l"
    using 1 4 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
  hence 6: "f(?l) = ?l"
    using 3 apx.order.antisym by blast
  have "y . f(y) = y  ?l  y"
  proof
    fix y
    show "f(y) = y  ?l  y"
    proof
      assume 7: "f(y) = y"
      hence 8: "?l  y  L"
        using assms(1) inf.cobounded2 is_least_fixpoint_def least_fixpoint semiring.add_mono by blast
      have "y  ν f"
        using 7 assms(2) greatest_fixpoint is_greatest_fixpoint_def by auto
      hence "d(L) * y  ?l  d(?l * bot) * top"
        using 3 5 by (smt (z3) apx.order.trans apx_def semiring.distrib_left sup.absorb_iff2 sup_assoc)
      thus "?l  y"
        using 8 by (simp add: apx_def)
    qed
  qed
  thus ?thesis
    using 1 6 by (smt (verit) kappa_mu_nu_def apx.is_least_fixpoint_def apx.least_fixpoint_char)
qed

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f  apx.has_least_fixpoint f"
  by (simp add: kappa_mu_nu_def)

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu f  kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_nu_below_mu_nu_2 by blast

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu f  nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def nu_below_mu_nu_2_nu_below_mu_nu)

definition kappa_mu_nu_L :: "('a  'a)  bool"
  where "kappa_mu_nu_L f  apx.has_least_fixpoint f  κ f = μ f  d(ν f * bot) * L"

definition nu_below_mu_nu_L :: "('a  'a)  bool"
  where "nu_below_mu_nu_L f  d(L) * ν f  μ f  d(ν f * bot) * top"

definition mu_nu_apx_nu_L :: "('a  'a)  bool"
  where "mu_nu_apx_nu_L f  μ f  d(ν f * bot) * L  ν f"

definition mu_nu_apx_meet_L :: "('a  'a)  bool"
  where "mu_nu_apx_meet_L f  has_apx_meet (μ f) (ν f)  μ f  ν f = μ f  d(ν f * bot) * L"

lemma n_below_l:
  "x  d(y * bot) * L  x  (y  L)"
  using d_mult_below l13 sup_right_isotone by auto

lemma n_equal_l:
  assumes "nu_below_mu_nu_L f"
    shows"μ f  d(ν f * bot) * L = μ f  (ν f  L)"
proof -
  have "ν f  L  (μ f  d(ν f * bot) * top)  L"
    using assms l31 nu_below_mu_nu_L_def by force
  also have "...  μ f  d(ν f * bot) * L"
    using distrib(4) inf.sup_monoid.add_commute meet_domain_top sup_left_isotone by force
  finally have "μ f  (ν f  L)  μ f  d(ν f * bot) * L"
    by auto
  thus ?thesis
    by (meson order.antisym n_below_l)
qed

lemma nu_below_mu_nu_L_nu_below_mu_nu:
  "nu_below_mu_nu_L f  nu_below_mu_nu f"
  using order_lesseq_imp sup.cobounded1 sup_left_isotone nu_below_mu_nu_L_def nu_below_mu_nu_def by blast

lemma nu_below_mu_nu_L_kappa_mu_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  isotone f  apx.isotone f  nu_below_mu_nu_L f  kappa_mu_nu_L f"
  using kappa_mu_nu_L_def kappa_mu_nu_def n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu by auto

lemma nu_below_mu_nu_L_mu_nu_apx_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  nu_below_mu_nu_L f  mu_nu_apx_nu_L f"
  using mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

lemma nu_below_mu_nu_L_mu_nu_apx_meet_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  nu_below_mu_nu_L f  mu_nu_apx_meet_L f"
  using mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2 by auto

lemma mu_nu_apx_nu_L_nu_below_mu_nu_L:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu_L f"
    shows "nu_below_mu_nu_L f"
proof -
  let ?n = "μ f  d(ν f * bot) * L"
  let ?l = "μ f  (ν f  L)"
  have "d(L) * ν f  ?n  d(?n * bot) * top"
    using assms(3) apx_def mu_nu_apx_nu_L_def by blast
  also have "...  ?n  d(?l * bot) * top"
    using d_isotone mult_left_isotone semiring.add_left_mono n_below_l by auto
  also have "...  ?n  d(ν f * bot) * top"
    by (meson assms(1,2) l_below_nu d_isotone mult_left_isotone sup_right_isotone)
  finally show ?thesis
    by (metis sup_assoc sup_right_top mult_left_dist_sup nu_below_mu_nu_L_def)
qed

lemma kappa_mu_nu_L_mu_nu_apx_nu_L:
  "has_greatest_fixpoint f  kappa_mu_nu_L f  mu_nu_apx_nu_L f"
  using kappa_mu_nu_L_def kappa_apx_below_nu mu_nu_apx_nu_L_def by force

lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L:
  "mu_nu_apx_meet_L f  mu_nu_apx_nu_L f"
  using apx_greatest_lower_bound mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def by fastforce

lemma kappa_mu_nu_L_nu_below_mu_nu_L:
  "has_least_fixpoint f  has_greatest_fixpoint f  kappa_mu_nu_L f  nu_below_mu_nu_L f"
  using kappa_mu_nu_L_mu_nu_apx_nu_L mu_nu_apx_nu_L_nu_below_mu_nu_L by auto

end

class itering_apx = domain_itering_lattice_L + domain_semiring_lattice_apx
begin

lemma circ_apx_isotone:
  assumes "x  y"
    shows "x  y"
proof -
  have 1: "x  y  L  d(L) * y  x  d(x * bot) * top"
    using assms apx_def by auto
  have "d(L) * y  (d(L) * y)"
    by (metis d_circ_import d_mult_below l2)
  also have "...  x * (d(x * bot) * top * x)"
    using 1 by (metis circ_sup_1 circ_isotone)
  also have "... = x  x * d(x * bot) * top"
    by (metis circ_left_top mult_assoc mult_left_dist_sup mult_1_right mult_top_circ)
  also have "...  x  d(x * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  finally have 2: "d(L) * y  x  d(x * bot) * top"
    using circ_plus_same d0_circ_left_unfold by auto
  have "x  y * L"
    using 1 by (metis circ_sup_1 circ_back_loop_fixpoint circ_isotone l40 le_iff_sup mult_assoc)
  also have "... = y  y * L"
    by (simp add: circ_L mult_left_dist_sup sup_commute)
  also have "...  y  y * bot  L"
    using l14 semiring.add_left_mono sup_monoid.add_assoc by auto
  finally have "x  y  L"
    using sup.absorb_iff1 zero_right_mult_decreasing by auto
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx = domain_omega_algebra_lattice_L + domain_semiring_lattice_apx

sublocale omega_algebra_apx < star: itering_apx where circ = star ..

context omega_algebra_apx
begin

lemma omega_apx_isotone:
  assumes "x  y"
    shows "xω  yω"
proof -
  have 1: "x  y  L  d(L) * y  x  d(x * bot) * top"
    using assms apx_def by auto
  have "d(L) * yω = (d(L) * y)ω"
    by (simp add: d_omega_export l2)
  also have "...  (x  d(x * bot) * top)ω"
    using 1 by (simp add: omega_isotone)
  also have "... = (x * d(x * bot) * top)ω  (x * d(x * bot) * top) * xω"
    by (simp add: ils.il_inf_associative omega_decompose)
  also have "...  x * d(x * bot) * top  (x * d(x * bot) * top) * xω"
    using mult_top_omega sup_left_isotone by blast
  also have "... = x * d(x * bot) * top  (1  x * d(x * bot) * top * (x * d(x * bot) * top)) * xω"
    by (simp add: star_left_unfold_equal)
  also have "...  xω  x * d(x * bot) * top"
    by (smt (verit, ccfv_threshold) sup_mono le_sup_iff mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone order_refl top_greatest)
  also have "...  xω  d(x * x * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_domain_top)
  also have "...  xω  d(x * bot) * top"
    by (simp add: dL_star.d0_circ_left_unfold star_plus)
  finally have 2: "d(L) * yω  xω  d(xω * bot) * top"
    by (meson sup_right_isotone d0_star_below_d0_omega mult_left_isotone order_trans)
  have "xω  (y  L)ω"
    using 1 by (simp add: omega_isotone)
  also have "... = (y * L)ω  (y * L) * yω"
    by (simp add: omega_decompose)
  also have "... = y * L * (y * L)ω  (y * L) * yω"
    using omega_unfold by auto
  also have "...  y * L  (y * L) * yω"
    using mult_L_omega omega_unfold sup_left_isotone by auto
  also have "... = y * L  (1  y * L * (y * L)) * yω"
    by (simp add: star_left_unfold_equal)
  also have "...  y * L  yω"
    by (simp add: dL_star.mult_L_circ_mult_below star_left_unfold_equal sup_commute)
  also have "...  y * bot  L  yω"
    by (simp add: l14 le_supI1)
  finally have "xω  yω  L"
    using star_bot_below_omega sup.left_commute sup.order_iff sup_commute by auto
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

lemma combined_apx_isotone:
  "x  y  (xω  L)  x * z  (yω  L)  y * z"
  using meet_L_apx_isotone mult_apx_left_isotone star.circ_apx_isotone sup_apx_isotone omega_apx_isotone by auto

lemma d_split_nu_mu:
  "d(L) * (yω  y * z)  y * z  ((yω  y * z)  L)  d((yω  y * z) * bot) * top"
proof -
  have "d(L) * yω  (yω  L)  d(yω * bot) * top"
    using l31 l91 omega_vector sup_right_isotone by auto
  hence "d(L) * (yω  y * z)  y * z  (yω  L)  d(yω * bot) * top"
    by (smt sup_assoc sup_commute sup_mono d_mult_below mult_left_dist_sup)
  also have "...  y * z  ((yω  y * z)  L)  d(yω * bot) * top"
    by (simp add: le_supI1 le_supI2)
  also have "...  y * z  ((yω  y * z)  L)  d((yω  y * z) * bot) * top"
    by (meson d_isotone mult_left_isotone sup.cobounded1 sup_right_isotone)
  finally show ?thesis
    .
qed

lemma loop_exists:
  "d(L) * ν (λx . y * x  z)  μ (λx . y * x  z)  (ν (λx . y * x  z)  L)  d(ν (λx . y * x  z) * bot) * top"
  by (simp add: d_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (λx . y * x  z) (μ (λx . y * x  z)  (ν (λx . y * x  z)  L))"
  using apx.least_fixpoint_char affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu kappa_mu_nu_def by auto

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (λx . y * x  z)"
  by (metis apx.has_least_fixpoint_def loop_apx_least_fixpoint)

lemma loop_semantics:
  "κ (λx . y * x  z) = μ (λx . y * x  z)  (ν (λx . y * x  z)  L)"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by auto

lemma loop_semantics_kappa_mu_nu:
  "κ (λx . y * x  z) = (yω  L)  y * z"
proof -
  have "κ (λx . y * x  z) = y * z  ((yω  y * z)  L)"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (metis sup.absorb2 sup_commute sup_ge2 sup_inf_distrib1)
qed

lemma loop_semantics_kappa_mu_nu_domain:
  "κ (λx . y * x  z) = d(yω) * L  y * z"
  by (simp add: omega_meet_L loop_semantics_kappa_mu_nu)

lemma loop_semantics_apx_isotone:
  "w  y  κ (λx . w * x  z)  κ (λx . y * x  z)"
  by (metis loop_semantics_kappa_mu_nu combined_apx_isotone)

end

end

Theory Extended_Designs

(* Title:      Extended Designs
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Extended Designs›

theory Extended_Designs

imports Omega_Algebras Domain

begin

class domain_semiring_L_below = left_zero_domain_semiring + L +
  assumes L_left_zero_below: "L * x  L"
  assumes mult_L_split: "x * L = x * bot  d(x) * L"
begin

lemma d_zero_mult_L:
  "d(x * bot) * L  x"
  by (metis le_sup_iff mult_L_split mult_assoc mult_left_zero zero_right_mult_decreasing)

lemma mult_L:
  "x * L  x * bot  L"
  by (metis sup_right_isotone d_mult_below mult_L_split)

lemma d_mult_L:
  "d(x) * L  x * L"
  by (metis sup_right_divisibility mult_L_split)

lemma d_L_split:
  "x * d(y) * L = x * bot  d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero mult_L_split mult_assoc mult_left_zero)

lemma d_mult_mult_L:
  "d(x * y) * L  x * d(y) * L"
  using d_L_split by auto

lemma L_L:
  "L * L = L"
  by (metis d_restrict_equals le_iff_sup mult_L_split zero_right_mult_decreasing)

end

class antidomain_semiring_L = left_zero_antidomain_semiring + L +
  assumes d_zero_mult_L: "d(x * bot) * L  x"
  assumes d_L_zero     : "d(L * bot) = 1"
  assumes mult_L       : "x * L  x * bot  L"
begin

lemma L_left_zero:
  "L * x = L"
  by (metis order.antisym d_L_zero d_zero_mult_L mult_assoc mult_left_one mult_left_zero zero_right_mult_decreasing)

subclass domain_semiring_L_below
  apply unfold_locales
  apply (simp add: L_left_zero)
  apply (rule order.antisym)
  apply (smt d_restrict_equals le_iff_sup mult_L mult_assoc mult_left_dist_sup)
  by (metis le_sup_iff d_L_zero d_mult_d d_zero_mult_L mult_assoc mult_right_isotone mult_1_right bot_least)

end

class ed_below = bounded_left_zero_omega_algebra + domain_semiring_L_below + Omega +
  assumes Omega_def: "xΩ = d(xω) * L  x"
begin

lemma Omega_isotone:
  "x  y  xΩ  yΩ"
  by (metis Omega_def sup_mono d_isotone mult_left_isotone omega_isotone star.circ_isotone)

lemma star_below_Omega:
  "x  xΩ"
  using Omega_def by auto

lemma one_below_Omega:
  "1  xΩ"
  using order_trans star.circ_reflexive star_below_Omega by blast

lemma L_left_zero_star:
  "L * x = L"
  by (meson L_left_zero_below order.antisym star.circ_back_loop_prefixpoint sup.boundedE)

lemma L_left_zero_Omega:
  "L * xΩ = L"
  using L_left_zero_star L_left_zero_below Omega_def mult_left_dist_sup sup.order_iff sup_monoid.add_commute by auto

lemma mult_L_star:
  "(x * L) = 1  x * L"
  by (metis L_left_zero_star mult_assoc star.circ_left_unfold)

lemma mult_L_omega_below:
  "(x * L)ω  x * L"
  by (metis L_left_zero_below mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L  y) = y  y * x * L"
  by (metis L_left_zero_star sup_commute mult_assoc star.circ_unfold_sum)

lemma mult_L_sup_omega_below:
  "(x * L  y)ω  yω  y * x * L"
proof -
  have "(x * L  y)ω = (y * x * L)ω  (y * x * L) * yω"
    by (simp add: ils.il_inf_associative omega_decompose sup_commute)
  also have "...  y * x * L  (y * x * L) * yω"
    using sup_left_isotone mult_L_omega_below by auto
  also have "... = y * x * L  y * x * L * yω  yω"
    by (smt L_left_zero_star sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint)
  also have "...  yω  y * x * L"
    by (metis L_left_zero_star sup_commute eq_refl mult_assoc star.circ_back_loop_fixpoint)
  finally show ?thesis
    .
qed

lemma mult_L_sup_circ:
  "(x * L  y)Ω = d(yω) * L  y  y * x * L"
proof -
  have "(x * L  y)Ω = d((x * L  y)ω) * L  (x * L  y)"
    by (simp add: Omega_def)
  also have "...  d(yω  y * x * L) * L  (x * L  y)"
    by (metis sup_left_isotone d_isotone mult_L_sup_omega_below mult_left_isotone)
  also have "... = d(yω) * L  d(y * x * L) * L  (x * L  y)"
    by (simp add: d_dist_sup mult_right_dist_sup)
  also have "...  d(yω) * L  y * x * L * L  (x * L  y)"
    by (meson d_mult_L order.refl sup.mono)
  also have "... = d(yω) * L  y  y * x * L"
    by (smt L_L sup_assoc sup_commute le_iff_sup mult_L_sup_star mult_assoc order_refl)
  finally have 1: "(x * L  y)Ω  d(yω) * L  y  y * x * L"
    .
  have 2: "d(yω) * L  (x * L  y)Ω"
    using Omega_isotone Omega_def by force
  have "y  y * x * L  (x * L  y)Ω"
    by (metis Omega_def sup_ge2 mult_L_sup_star)
  hence "d(yω) * L  y  y * x * L  (x * L  y)Ω"
    using 2 by simp
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

lemma circ_sup_d:
  "(xΩ * y)Ω * xΩ = d((x * y)ω) * L  ((x * y) * x  (x * y) * d(xω) * L)"
proof -
  have "(xΩ * y)Ω * xΩ = ((d(xω) * L  x) * y)Ω * xΩ"
    by (simp add: Omega_def)
  also have "... = (d(xω) * L * y  x * y)Ω * xΩ"
    by (simp add: mult_right_dist_sup)
  also have "...  (d(xω) * L  x * y)Ω * xΩ"
    by (metis L_left_zero_below Omega_isotone sup_left_isotone mult_assoc mult_left_isotone mult_right_isotone)
  also have "... = (d((x * y)ω) * L  (x * y)  (x * y) * d(xω) * L) * xΩ"
    by (simp add: mult_L_sup_circ)
  also have "... = d((x * y)ω) * L * xΩ  (x * y) * xΩ  (x * y) * d(xω) * L * xΩ"
    using mult_right_dist_sup by auto
  also have "... = d((x * y)ω) * L  (x * y) * xΩ  (x * y) * d(xω) * L"
    by (simp add: L_left_zero_Omega mult.assoc)
  also have "... = d((x * y)ω) * L  ((x * y) * x  (x * y) * d(xω) * L)"
    by (simp add: Omega_def ils.il_inf_associative semiring.distrib_left sup_left_commute sup_monoid.add_commute)
  finally have 1: "(xΩ * y)Ω * xΩ  d((x * y)ω) * L  ((x * y) * x  (x * y) * d(xω) * L)"
    .
  have "d((x * y)ω) * L  (xΩ * y)Ω"
    using Omega_isotone Omega_def mult_left_isotone by auto
  also have "...  (xΩ * y)Ω * xΩ"
    by (metis mult_right_isotone mult_1_right one_below_Omega)
  finally have 2: "d((x * y)ω) * L  (xΩ * y)Ω * xΩ"
    .
  have 3: "(x * y) * x  (xΩ * y)Ω * xΩ"
    by (meson Omega_isotone order.trans mult_left_isotone mult_right_isotone star_below_Omega)
  have "(x * y) * d(xω) * L  (x * y) * xΩ"
    by (metis Omega_def sup_commute mult_assoc mult_left_sub_dist_sup_right)
  also have "...  (xΩ * y)Ω * xΩ"
    using Omega_isotone Omega_def mult_left_isotone by force
  finally have "d((x * y)ω) * L  ((x * y) * x  (x * y) * d(xω) * L)  (xΩ * y)Ω * xΩ"
    using 2 3 by (simp add: sup_assoc)
  thus ?thesis
    using 1 by (simp add: order.antisym)
qed

(*
lemma mult_L_omega: "(x * L)ω = x * L" nitpick [expect=genuine,card=5] oops
lemma mult_L_sup_omega: "(x * L ⊔ y)ω = yω ⊔ y * x * L" nitpick [expect=genuine,card=5] oops
lemma d_Omega_circ_simulate_right_plus: "z * x ≤ y * yΩ * z ⊔ w ⟹ z * xΩ ≤ yΩ * (z ⊔ w * xΩ)" nitpick [expect=genuine,card=4] oops
lemma d_Omega_circ_simulate_left_plus: "x * z ≤ z * yΩ ⊔ w ⟹ xΩ * z ≤ (z ⊔ xΩ * w) * yΩ" nitpick [expect=genuine,card=3] oops
*)

end

class ed = ed_below +
  assumes L_left_zero: "L * x = L"
begin

lemma mult_L_omega:
  "(x * L)ω = x * L"
  by (metis L_left_zero omega_slide)

lemma mult_L_sup_omega:
  "(x * L  y)ω = yω  y * x * L"
  by (metis L_left_zero ils.il_inf_associative mult_bot_add_omega sup_commute)

lemma d_Omega_circ_simulate_right_plus:
  assumes "z * x  y * yΩ * z  w"
    shows "z * xΩ  yΩ * (z  w * xΩ)"
proof -
  have "z * x  y * d(yω) * L * z  y * y * z  w"
    using assms Omega_def ils.il_inf_associative mult_right_dist_sup semiring.distrib_left by auto
  also have "...  y * d(yω) * L  y * y * z  w"
    by (metis L_left_zero_below sup_commute sup_right_isotone mult_assoc mult_right_isotone)
  also have "... = y * bot  d(y * yω) * L  y * y * z  w"
    by (simp add: d_L_split)
  also have "... = d(yω) * L  y * y * z  w"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup omega_unfold)
  finally have 1: "z * x  d(yω) * L  y * y * z  w"
    .
  have "(d(yω) * L  y * z  y * w * d(xω) * L  y * w * x) * x = d(yω) * L * x  y * z * x  y * w * d(xω) * L * x  y * w * x * x"
    using mult_right_dist_sup by fastforce
  also have "...  d(yω) * L  y * z * x  y * w * d(xω) * L * x  y * w * x * x"
    by (metis L_left_zero_below sup_left_isotone mult_assoc mult_right_isotone)
  also have "...  d(yω) * L  y * z * x  y * w * d(xω) * L  y * w * x * x"
    by (metis L_left_zero_below sup_commute sup_left_isotone mult_assoc mult_right_isotone)
  also have "...  d(yω) * L  y * z * x  y * w * d(xω) * L  y * w * x"
    by (meson star.circ_back_loop_prefixpoint sup.boundedE sup_right_isotone)
  also have "...  d(yω) * L  y * (d(yω) * L  y * y * z  w)  y * w * d(xω) * L  y * w * x"
    using 1 by (smt sup_left_isotone sup_right_isotone le_iff_sup mult_assoc mult_left_dist_sup)
  also have "... = d(yω) * L  y * y * y * z  y * w * d(xω) * L  y * w * x"
    by (smt sup_assoc sup_commute sup_idem mult_assoc mult_left_dist_sup d_L_split star.circ_back_loop_fixpoint star_mult_omega)
  also have "...  d(yω) * L  y * z  y * w * d(xω) * L  y * w * x"
    using mult_isotone order_refl semiring.add_right_mono star.circ_mult_upper_bound star.right_plus_below_circ sup_right_isotone by auto
  finally have 2: "z * x  d(yω) * L  y * z  y * w * d(xω) * L  y * w * x"
    by (smt le_sup_iff sup_ge1 star.circ_loop_fixpoint star_right_induct)
  have "z * x * xω  y * y * z * xω  d(yω) * L * xω  w * xω"
    using 1 by (metis sup_commute mult_left_isotone mult_right_dist_sup)
  also have "...  y * y * z * xω  d(yω) * L  w * xω"
    by (metis L_left_zero eq_refl ils.il_inf_associative)
  finally have "z * xω  yω  y * d(yω) * L  y * w * xω"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup omega_induct omega_unfold star.left_plus_circ)
  hence "z * xω  yω  y * w * xω"
    by (metis sup_commute d_mult_L le_iff_sup mult_assoc mult_right_isotone omega_sub_vector order_trans star_mult_omega)
  hence "d(z * xω) * L  d(yω) * L  y * w * d(xω) * L"
    by (smt sup_assoc sup_commute d_L_split d_dist_sup le_iff_sup mult_right_dist_sup)
  hence "z * d(xω) * L  z * bot  d(yω) * L  y * w * d(xω) * L"
    using d_L_split sup_assoc sup_right_isotone by force
  also have "...  y * z  d(yω) * L  y * w * d(xω) * L"
    by (smt sup_commute sup_left_isotone sup_ge1 order_trans star.circ_loop_fixpoint zero_right_mult_decreasing)
  finally have "z * d(xω) * L  d(yω) * L  y * z  y * w * d(xω) * L  y * w * x"
    by (simp add: le_supI2 sup_commute)
  thus ?thesis
    using 2 by (smt L_left_zero Omega_def sup_assoc le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup)
qed

lemma d_Omega_circ_simulate_left_plus:
  assumes "x * z  z * yΩ  w"
    shows "xΩ * z  (z  xΩ * w) * yΩ"
proof -
  have "x * (z * d(yω) * L  z * y  d(xω) * L  x * w * d(yω) * L  x * w * y) = x * z * d(yω) * L  x * z * y  d(xω) * L  x * x * w * d(yω) * L  x * x * w * y"
    by (smt sup_assoc sup_commute mult_assoc mult_left_dist_sup d_L_split omega_unfold)
  also have "...  (z * d(yω) * L  z * y  w) * d(yω) * L  (z * d(yω) * L  z * y  w) * y  d(xω) * L  x * w * d(yω) * L  x * w * y"
    by (smt assms Omega_def sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_loop_fixpoint)
  also have "... = z * d(yω) * L  z * y * d(yω) * L  w * d(yω) * L  z * y  w * y  d(xω) * L  x * w * d(yω) * L  x * w * y"
    by (smt L_left_zero sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_transitive_equal)
  also have "... = z * d(yω) * L  w * d(yω) * L  z * y  w * y  d(xω) * L  x * w * d(yω) * L  x * w * y"
    by (smt sup_assoc sup_commute sup_idem le_iff_sup mult_assoc d_L_split star_mult_omega zero_right_mult_decreasing)
  finally have "x * (z * d(yω) * L  z * y  d(xω) * L  x * w * d(yω) * L  x * w * y)  z * d(yω) * L  z * y  d(xω) * L  x * w * d(yω) * L  x * w * y"
    by (smt sup_assoc sup_commute sup_idem mult_assoc star.circ_loop_fixpoint)
  thus ?thesis
    by (smt (verit, del_insts) L_left_zero Omega_def sup_assoc le_sup_iff sup_ge1 mult_assoc mult_left_dist_sup mult_right_dist_sup star.circ_back_loop_fixpoint star_left_induct)
qed

end

text ‹Theorem 2.5 and Theorem 50.4›

sublocale ed < ed_omega: itering where circ = Omega
  apply unfold_locales
  apply (smt sup_assoc sup_commute sup_bot_left circ_sup_d Omega_def mult_left_dist_sup mult_right_dist_sup d_L_split d_dist_sup omega_decompose star.circ_sup_1 star.circ_slide)
  apply (smt L_left_zero sup_assoc sup_commute sup_bot_left Omega_def mult_assoc mult_left_dist_sup mult_right_dist_sup d_L_split omega_slide star.circ_mult)
  using d_Omega_circ_simulate_right_plus apply blast
  by (simp add: d_Omega_circ_simulate_left_plus)

sublocale ed < ed_star: itering where circ = star ..

class ed_2 = ed_below + antidomain_semiring_L + Omega
begin

subclass ed
  apply unfold_locales
  by (rule L_left_zero)

end

end

Theory Relative_Domain

(* Title:      Relative Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Relative Domain›

theory Relative_Domain

imports Tests

begin

class Z =
  fixes Z :: "'a"

class relative_domain_semiring = idempotent_left_semiring + dom + Z +
  assumes d_restrict : "x  d(x) * x  Z"
  assumes d_mult_d   : "d(x * y) = d(x * d(y))"
  assumes d_below_one: "d(x)  1"
  assumes d_Z        : "d(Z) = bot"
  assumes d_dist_sup : "d(x  y) = d(x)  d(y)"
  assumes d_export   : "d(d(x) * y) = d(x) * d(y)"
begin

lemma d_plus_one: 
  "d(x)  1 = 1"
  by (simp add: d_below_one sup_absorb2)

text ‹Theorem 44.2›

lemma d_zero:
  "d(bot) = bot"
  by (metis d_Z d_export mult_left_zero)

text ‹Theorem 44.3›

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(y . x = d(y))  x = d(x)"
  using d_involutive by auto

lemma d_type:
  "P . (x . x = d(x)  P(x))  (x . P(d(x)))"
  by (metis d_involutive)

text ‹Theorem 44.4›

lemma d_mult_sub:
  "d(x * y)  d(x)"
  by (smt (verit, ccfv_threshold) d_plus_one d_dist_sup d_mult_d le_iff_sup mult.right_neutral mult_left_sub_dist_sup_right sup_commute)

lemma d_sub_one:
  "x  1  x  d(x)  Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone mult_1_right order_trans)

lemma d_one:
  "d(1)  Z = 1  Z"
  by (meson d_sub_one d_below_one order.trans preorder_one_closed sup.cobounded1 sup_same_context)

text ‹Theorem 44.8›

lemma d_strict:
  "d(x) = bot  x  Z"
  by (metis sup_commute sup_bot_right d_Z d_dist_sup d_restrict le_iff_sup mult_left_zero)

text ‹Theorem 44.1›

lemma d_isotone:
  "x  y  d(x)  d(y)"
  using d_dist_sup sup_right_divisibility by force

lemma d_plus_left_upper_bound:
  "d(x)  d(x  y)"
  by (simp add: d_isotone)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (smt (verit, ccfv_threshold) d_involutive d_mult_sub d_Z d_dist_sup d_export d_restrict le_iff_sup sup_bot_left sup_commute)

text ‹Theorem 44.12›

lemma d_least_left_preserver:
  "x  d(y) * x  Z  d(x)  d(y)"
  apply (rule iffI)
  apply (smt (z3) comm_monoid.comm_neutral d_involutive d_mult_sub d_plus_left_upper_bound d_Z d_dist_sup order_trans sup_absorb2 sup_bot.comm_monoid_axioms)
  by (smt (verit, del_insts) d_restrict mult_right_dist_sup sup.cobounded1 sup.orderE sup_assoc sup_commute)

text ‹Theorem 44.9›

lemma d_weak_locality:
  "x * y  Z  x * d(y)  Z"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x)  d(y)) = d(x)  d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y)  d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x)  d(y)) = d(x)"
  by (smt d_sup_closed d_export d_idempotent d_involutive d_mult_sub order.eq_iff mult_left_sub_dist_sup_left)

lemma d_sup_left_absorb_mult:
  "d(x)  d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis sup_commute order.antisym d_sup_left_absorb_mult d_below_one d_export d_mult_left_absorb_sup mult_assoc mult_left_isotone mult_left_one)

lemma d_mult_greatest_lower_bound:
  "d(x)  d(y) * d(z)  d(x)  d(y)  d(x)  d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_sup_left_dist_mult:
  "d(x)  d(y) * d(z) = (d(x)  d(y)) * (d(x)  d(z))"
  by (metis sup_assoc d_commutative d_dist_sup d_idempotent d_mult_left_absorb_sup mult_right_dist_sup)

lemma d_order:
  "d(x)  d(y)  d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

text ‹Theorem 44.6›

lemma Z_mult_decreasing:
  "Z * x  Z"
  by (metis d_mult_sub bot.extremum d_strict order.eq_iff)

text ‹Theorem 44.5›

lemma d_below_d_one:
  "d(x)  d(1)"
  by (metis d_mult_sub mult_left_one)

text ‹Theorem 44.7›

lemma d_relative_Z:
  "d(x) * x  Z = x  Z"
  by (metis sup_ge1 sup_same_context d_below_one d_restrict mult_isotone mult_left_one)

lemma Z_left_zero_above_one:
  "1  x  Z * x = Z"
  by (metis Z_mult_decreasing order.eq_iff mult_right_isotone mult_1_right)

text ‹Theorem 44.11›

lemma kat_4:
  "d(x) * y = d(x) * y * d(z)  d(x) * y  y * d(z)"
  by (metis d_below_one mult_left_isotone mult_left_one)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z)  d(x) * y  y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_right_isotone)
  by (metis d_below_one mult_right_isotone mult_1_right)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x)  y * d(x)  d(z) * y"
  apply (rule iffI)
  using d_below_one mult_right_isotone apply fastforce
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_left_isotone)
  by (metis d_below_one mult_left_isotone mult_left_one)

text ‹Theorem 44.10›

lemma d_restrict_iff_1:
  "d(x) * y  z  d(x) * y  d(x) * z"
  by (smt (verit, del_insts) d_below_one d_idempotent mult_assoc mult_left_isotone mult_left_one mult_right_isotone order_trans)

(* independence of axioms, checked in relative_domain_semiring without the respective axiom:
lemma d_restrict : "x ≤ d(x) * x ⊔ Z" nitpick [expect=genuine,card=2] oops
lemma d_mult_d   : "d(x * y) = d(x * d(y))" nitpick [expect=genuine,card=3] oops
lemma d_below_one: "d(x) ≤ 1" nitpick [expect=genuine,card=3] oops
lemma d_Z        : "d(Z) = bot" nitpick [expect=genuine,card=2] oops
lemma d_dist_sup : "d(x ⊔ y) = d(x) ⊔ d(y)" nitpick [expect=genuine,card=3] oops
lemma d_export   : "d(d(x) * y) = d(x) * d(y)" nitpick [expect=genuine,card=5] oops
*)

end

typedef (overloaded) 'a dImage = "{ x::'a::relative_domain_semiring . (y::'a . x = d(y)) }"
  by auto

lemma simp_dImage[simp]:
  "y . Rep_dImage x = d(y)"
  using Rep_dImage by simp

setup_lifting type_definition_dImage

text ‹Theorem 44›

instantiation dImage :: (relative_domain_semiring) bounded_distrib_lattice
begin

lift_definition sup_dImage :: "'a dImage  'a dImage  'a dImage" is sup
  by (metis d_dist_sup)

lift_definition inf_dImage :: "'a dImage  'a dImage  'a dImage" is times
  by (metis d_export)

lift_definition bot_dImage :: "'a dImage" is bot
  by (metis d_zero)

lift_definition top_dImage :: "'a dImage" is "d(1)"
  by auto

lift_definition less_eq_dImage :: "'a dImage  'a dImage  bool" is less_eq .

lift_definition less_dImage :: "'a dImage  'a dImage  bool" is less .

instance
  apply intro_classes
  apply (simp add: less_dImage.rep_eq less_eq_dImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_dImage.rep_eq)
  using less_eq_dImage.rep_eq apply simp
  apply (simp add: Rep_dImage_inject less_eq_dImage.rep_eq)
  apply (metis (mono_tags) d_involutive d_mult_sub inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq order_refl simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: bot_dImage.rep_eq less_eq_dImage.rep_eq)
  apply (smt (z3) d_below_d_one less_eq_dImage.rep_eq simp_dImage top_dImage.rep_eq)
  by (smt (z3) inf_dImage.rep_eq sup_dImage.rep_eq simp_dImage Rep_dImage_inject d_sup_left_dist_mult)

end

class bounded_relative_domain_semiring = relative_domain_semiring + bounded_idempotent_left_semiring
begin

lemma Z_top:
  "Z * top = Z"
  by (simp add: Z_left_zero_above_one)

lemma d_restrict_top:
  "x  d(x) * top  Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone order_trans top_greatest)

(*
lemma d_one_one: "d(1) = 1" nitpick [expect=genuine,card=2] oops
*)

end

class relative_domain_semiring_split = relative_domain_semiring +
  assumes split_Z: "x * (y  Z)  x * y  Z"
begin

lemma d_restrict_iff:
  "(x  y  Z)  (x  d(x) * y  Z)"
proof -
  have "x  y  Z  x  d(x) * (y  Z)  Z"
    by (smt sup_left_isotone d_restrict le_iff_sup mult_left_sub_dist_sup_left order_trans)
  hence "x  y  Z  x  d(x) * y  Z"
    by (meson le_supI order_lesseq_imp split_Z sup.cobounded2)
  thus ?thesis
    by (meson d_restrict_iff_1 le_supI mult_left_sub_dist_sup_left order_lesseq_imp sup.cobounded2)
qed

end

class relative_antidomain_semiring = idempotent_left_semiring + dom + Z + uminus +
  assumes a_restrict  : "-x * x  Z"
  assumes a_mult_d    : "-(x * y) = -(x * --y)"
  assumes a_complement: "-x * --x = bot"
  assumes a_Z         : "-Z = 1"
  assumes a_export    : "-(--x * y) = -x  -y"
  assumes a_dist_sup  : "-(x  y) = -x * -y"
  assumes d_def       : "d(x) = --x"
begin

notation
  uminus ("a")

text ‹Theorem 45.7›

lemma a_complement_one:
  "--x  -x = 1"
  by (metis a_Z a_complement a_export a_mult_d mult_left_one)

text ‹Theorem 45.5 and Theorem 45.6›

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (metis a_mult_d d_def mult_left_one)

lemma a_below_one:
  "a(x)  1"
  using a_complement_one sup_right_divisibility by auto

lemma a_export_a:
  "a(a(x) * y) = d(x)  a(y)"
  by (metis a_d_closed a_export d_def)

lemma a_sup_absorb:
  "(x  a(y)) * a(a(y)) = x * a(a(y))"
  by (simp add: a_complement mult_right_dist_sup)

text ‹Theorem 45.10›

lemma a_greatest_left_absorber:
  "a(x) * y  Z  a(x)  a(y)"
  apply (rule iffI)
  apply (smt a_Z a_sup_absorb a_dist_sup a_export_a a_mult_d sup_commute d_def le_iff_sup mult_left_one)
  by (meson a_restrict mult_isotone order.refl order_trans)

lemma a_plus_left_lower_bound:
  "a(x  y)  a(x)"
  by (metis a_greatest_left_absorber a_restrict sup_commute mult_left_sub_dist_sup_right order_trans)

text ‹Theorem 45.2›

subclass relative_domain_semiring
  apply unfold_locales
  apply (smt (verit) a_Z a_complement_one a_restrict sup_commute sup_ge1 case_split_left d_def order_trans)
  using a_mult_d d_def apply force
  apply (simp add: a_below_one d_def)
  apply (metis a_Z a_complement d_def mult_left_one)
  apply (simp add: a_export_a a_dist_sup d_def)
  using a_dist_sup a_export d_def by auto

text ‹Theorem 45.1›

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis a_dist_sup sup_commute)
  apply (smt a_complement a_d_closed a_export_a sup_bot_right d_sup_left_dist_mult)
  apply (metis a_d_closed a_dist_sup d_def)
  apply (rule the_equality[THEN sym])
  apply (simp add: a_complement)
  apply (simp add: a_complement)
  using a_d_closed a_Z d_Z d_def apply force
  using a_export a_mult_d apply fastforce
  apply (metis a_d_closed d_order)
  by (simp add: less_le_not_le)

lemma a_plus_mult_d:
  "-(x * y)  -(x * --y) = -(x * --y)"
  using a_mult_d by auto

lemma a_mult_d_2:
  "a(x * y) = a(x * d(y))"
  using a_mult_d d_def by auto

lemma a_3:
  "a(x) * a(y) * d(x  y) = bot"
  by (metis a_complement a_dist_sup d_def)

lemma a_fixpoint:
  "x . (a(x) = x  (y . y = bot))"
  by (metis a_complement_one mult_1_left mult_left_zero order.refl sup.order_iff tests_dual.one_def)

text ‹Theorem 45.9›

lemma a_strict:
  "a(x) = 1  x  Z"
  by (metis a_Z d_def d_strict order.refl tests_dual.sba_dual.double_negation)

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: d_def tests_dual.sub_commutative)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot  a(x)  a(y)"
  by (simp add: d_def tests_dual.sba_dual.less_eq_inf_bot)

lemma a_antitone:
  "x  y  a(y)  a(x)"
  using a_plus_left_lower_bound sup_commute sup_right_divisibility by fastforce

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x  y)"
  by (simp add: a_dist_sup d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x)  d(y)"
  by (simp add: a_mult_deMorgan d_dist_sup)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x)  a(y)"
  using a_export d_def by auto

lemma a_plus_deMorgan:
  "a(a(x)  a(y)) = d(x) * d(y)"
  by (simp add: a_dist_sup d_def)

lemma a_plus_deMorgan_1:
  "a(d(x)  d(y)) = a(x) * a(y)"
  by (simp add: a_dist_sup d_def)

text ‹Theorem 45.8›

lemma a_mult_left_upper_bound:
  "a(x)  a(x * y)"
  using a_shunting_zero d_def d_mult_sub tests_dual.less_eq_sup_top by auto

text ‹Theorem 45.6›

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x)  a(y)"
  by (simp add: a_export d_def)

lemma a_7:
  "d(x) * a(d(y)  d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y)  d(z)  d(x)  d(z)  d(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_d_shunting:
  "d(x) * d(y)  d(z)  d(x)  d(z)  a(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_cancellation_1:
  "d(x)  d(y)  (d(x) * a(y))"
  by (smt (z3) a_d_closed d_a_shunting d_export eq_refl sup_commute)

lemma d_cancellation_2:
  "(d(z)  d(y)) * a(y)  d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x)  a(y)) = a(x)  a(y)"
  using a_mult_deMorgan tests_dual.sub_inf_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using d_def tests_dual.sub_sup_closed by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot  d(x)  d(y)"
  using a_shunting_zero d_def by force

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot  d(x)  a(y)"
  using d_a_shunting_zero d_def by auto

lemma d_compl_intro:
  "d(x)  d(y) = d(x)  a(x) * d(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma a_compl_intro:
  "a(x)  a(y) = a(x)  d(x) * a(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma kat_2:
  "y * a(z)  a(x) * y  d(x) * y * a(z) = bot"
  by (metis d_complement_zero order.eq_iff mult_assoc mult_left_zero mult_right_isotone bot_least)

text ‹Theorem 45.4›

lemma kat_2_equiv:
  "y * a(z)  a(x) * y  d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (smt (verit, best) a_Z a_below_one a_complement_one case_split_left d_def mult_assoc mult_right_isotone mult_1_right bot_least)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot  y * d(x) = d(z) * y * d(x)"
  using kat_2_equiv d_def kat_4_equiv_opp by auto

text ‹Theorem 45.4›

lemma kat_3_equiv_opp_2:
  "d(z) * y * a(x) = bot  y * a(x) = a(z) * y * a(x)"
  by (metis a_d_closed kat_3_equiv_opp d_def)

lemma kat_equiv_6:
  "d(x) * y * a(z) = d(x) * y * bot  d(x) * y * a(z)  y * bot"
  by (metis d_restrict_iff_1 order.eq_iff mult_left_sub_dist_sup_right tests_dual.sba_dual.sup_right_unit mult_assoc)

lemma d_one_one:
  "d(1) = 1"
  by (simp add: d_def)

lemma case_split_left_sup:
  "-p * x  y  --p * x  z  x  y  z"
  by (smt (z3) a_complement_one case_split_left order_lesseq_imp sup.cobounded2 sup_ge1)

lemma test_mult_left_sub_dist_shunt:
  "-p * (--p * x  Z)  Z"
  by (simp add: a_greatest_left_absorber a_Z a_dist_sup a_export)

lemma test_mult_left_dist_shunt:
  "-p * (--p * x  Z) = -p * Z"
  by (smt (verit, ccfv_SIG) order.antisym mult_left_sub_dist_sup_right sup.orderE tests_dual.sba_dual.sup_idempotent mult_assoc test_mult_left_sub_dist_shunt tests_dual.sup_absorb)

(* independence of axioms, checked in relative_antidomain_semiring without the respective axiom:
lemma a_restrict  : "-x * x ≤ Z" nitpick [expect=genuine,card=3] oops
lemma a_mult_d    : "-(x * y) = -(x * --y)" nitpick [expect=genuine,card=3] oops
lemma a_complement: "-x * --x = bot" nitpick [expect=genuine,card=2] oops
lemma a_Z         : "-Z = 1" nitpick [expect=genuine,card=2] oops
lemma a_export    : "-(--x * y) = -x ⊔ -y" nitpick [expect=genuine,card=5] oops
lemma a_dist_sup  : "-(x ⊔ y) = -x * -y" nitpick [expect=genuine,card=3] oops
lemma d_def       : "d(x) = --x" nitpick [expect=genuine,card=2] oops
*)

end

typedef (overloaded) 'a aImage = "{ x::'a::relative_antidomain_semiring . (y::'a . x = a(y)) }"
  by auto

lemma simp_aImage[simp]:
  "y . Rep_aImage x = a(y)"
  using Rep_aImage by simp

setup_lifting type_definition_aImage

text ‹Theorem 45.3›

instantiation aImage :: (relative_antidomain_semiring) boolean_algebra
begin

lift_definition sup_aImage :: "'a aImage  'a aImage  'a aImage" is sup
  using tests_dual.sba_dual.sba_dual.inf_closed by auto

lift_definition inf_aImage :: "'a aImage  'a aImage  'a aImage" is times
  using tests_dual.sba_dual.inf_closed by auto

lift_definition minus_aImage :: "'a aImage  'a aImage  'a aImage" is "λx y . x * a(y)"
  using tests_dual.sba_dual.inf_closed by blast

lift_definition uminus_aImage :: "'a aImage  'a aImage" is a
  by auto

lift_definition bot_aImage :: "'a aImage" is bot
  by (metis tests_dual.sba_dual.sba_dual.complement_bot)

lift_definition top_aImage :: "'a aImage" is 1
  using a_Z by auto

lift_definition less_eq_aImage :: "'a aImage  'a aImage  bool" is less_eq .

lift_definition less_aImage :: "'a aImage  'a aImage  bool" is less .

instance
  apply intro_classes
  apply (simp add: less_aImage.rep_eq less_eq_aImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_aImage.rep_eq)
  using less_eq_aImage.rep_eq apply simp
  apply (simp add: Rep_aImage_inject less_eq_aImage.rep_eq)
  apply (metis (mono_tags) a_below_one inf_aImage.rep_eq less_eq_aImage.rep_eq mult.right_neutral mult_right_isotone simp_aImage)
  apply (metis (mono_tags, lifting) less_eq_aImage.rep_eq a_d_closed a_export bot.extremum_unique inf_aImage.rep_eq kat_equiv_6 mult.assoc mult.left_neutral mult_left_isotone mult_left_zero simp_aImage sup.cobounded1 tests_dual.sba_dual.sba_dual.complement_top)
  apply (smt (z3) less_eq_aImage.rep_eq inf_aImage.rep_eq mult_isotone simp_aImage tests_dual.sba_dual.inf_idempotent)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  using less_eq_aImage.rep_eq sup_aImage.rep_eq apply force
  apply (simp add: less_eq_aImage.rep_eq bot_aImage.rep_eq)
  apply (smt (z3) less_eq_aImage.rep_eq a_below_one simp_aImage top_aImage.rep_eq)
  apply (metis (mono_tags, lifting) tests_dual.sba_dual.sba_dual.inf_left_dist_sup Rep_aImage_inject inf_aImage.rep_eq sup_aImage.rep_eq simp_aImage)
  apply (smt (z3) inf_aImage.rep_eq uminus_aImage.rep_eq Rep_aImage_inject a_complement bot_aImage.rep_eq simp_aImage)
  apply (smt (z3) top_aImage.rep_eq Rep_aImage_inject a_complement_one simp_aImage sup_aImage.rep_eq sup_commute uminus_aImage.rep_eq)
  by (metis (mono_tags) inf_aImage.rep_eq Rep_aImage_inject minus_aImage.rep_eq uminus_aImage.rep_eq)

end

class bounded_relative_antidomain_semiring = relative_antidomain_semiring + bounded_idempotent_left_semiring
begin

subclass bounded_relative_domain_semiring ..

lemma a_top:
  "a(top) = bot"
  by (metis a_plus_left_lower_bound bot_unique sup_right_top tests_dual.sba_dual.complement_top)

lemma d_top:
  "d(top) = 1"
  using a_top d_def by auto

lemma shunting_top_1:
  "-p * x  y  x  --p * top  y"
  by (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)

lemma shunting_Z:
  "-p * x  Z  x  --p * top  Z"
  apply (rule iffI)
  apply (simp add: shunting_top_1)
  by (smt a_top a_Z a_antitone a_dist_sup a_export a_greatest_left_absorber sup_commute sup_bot_right mult_left_one)

(*
lemma a_left_dist_sup: "-p * (y ⊔ z) = -p * y ⊔ -p * z" nitpick [expect=genuine,card=7] oops
lemma shunting_top: "-p * x ≤ y ⟷ x ≤ --p * top ⊔ y" nitpick [expect=genuine,card=7] oops
*)

end

class relative_left_zero_antidomain_semiring = relative_antidomain_semiring + idempotent_left_zero_semiring
begin

lemma kat_3:
  "d(x) * y * a(z) = bot  d(x) * y = d(x) * y * d(z)"
  by (metis d_def mult_1_right mult_left_dist_sup sup_monoid.add_0_left tests_dual.inf_complement)

lemma a_a_below:
  "a(a(x)) * y  y"
  using d_def d_restrict_iff_1 by auto

lemma kat_equiv_5:
  "d(x) * y  y * d(z)  d(x) * y * a(z) = d(x) * y * bot"
proof
  assume "d(x) * y  y * d(z)"
  thus "d(x) * y * a(z) = d(x) * y * bot"
    by (metis d_complement_zero kat_4_equiv mult_assoc)
next
  assume "d(x) * y * a(z) = d(x) * y * bot"
  hence "a(a(x)) * y * a(z)  y * a(a(z))"
    by (simp add: a_a_below d_def mult_isotone)
  thus "d(x) * y  y * d(z)"
    by (metis a_a_below a_complement_one case_split_right d_def mult_isotone order_refl)
qed

lemma case_split_right_sup:
  "x * -p  y  x * --p  z  x  y  z"
  by (smt (verit, ccfv_SIG) a_complement_one order.trans mult_1_right mult_left_dist_sup sup_commute sup_right_isotone)

end

class bounded_relative_left_zero_antidomain_semiring = relative_left_zero_antidomain_semiring + bounded_idempotent_left_zero_semiring
begin

lemma shunting_top:
  "-p * x  y  x  --p * top  y"
  apply (rule iffI)
  apply (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)
  by (metis a_complement sup_bot_left sup_right_divisibility mult_assoc mult_left_dist_sup mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone order_trans tests_dual.inf_left_unit)

end

end

Theory Relative_Modal

(* Title:      Relative Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Relative Modal Operators›

theory Relative_Modal

imports Relative_Domain

begin

class relative_diamond_semiring = relative_domain_semiring + diamond +
  assumes diamond_def: "|x>y = d(x * y)"
begin

lemma diamond_x_1:
  "|x>1 = d(x)"
  by (simp add: diamond_def)

lemma diamond_x_d:
  "|x>d(y) = d(x * y)"
  using d_mult_d diamond_def by auto

lemma diamond_x_und:
  "|x>d(y) = |x>y"
  using diamond_x_d diamond_def by auto

lemma diamond_d_closed:
  "|x>y = d( |x>y)"
  by (simp add: d_involutive diamond_def)

text ‹Theorem 46.11›

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: d_zero diamond_def)

lemma diamond_1_y:
  "|1>y = d(y)"
  by (simp add: diamond_def)

text ‹Theorem 46.12›

lemma diamond_1_d:
  "|1>d(y) = d(y)"
  by (simp add: diamond_1_y diamond_x_und)

text ‹Theorem 46.10›

lemma diamond_d_y:
  "|d(x)>y = d(x) * d(y)"
  by (simp add: d_export diamond_def)

text ‹Theorem 46.11›

lemma diamond_d_bot:
  "|d(x)>bot = bot"
  by (metis diamond_bot_y diamond_d_y d_commutative d_zero)

text ‹Theorem 46.12›

lemma diamond_d_1:
  "|d(x)>1 = d(x)"
  by (simp add: diamond_x_1 d_involutive)

lemma diamond_d_d:
  "|d(x)>d(y) = d(x) * d(y)"
  by (simp add: diamond_d_y diamond_x_und)

text ‹Theorem 46.12›

lemma diamond_d_d_same:
  "|d(x)>d(x) = d(x)"
  by (simp add: diamond_d_d d_idempotent)

text ‹Theorem 46.2›

lemma diamond_left_dist_sup:
  "|x  y>z = |x>z  |y>z"
  by (simp add: d_dist_sup diamond_def mult_right_dist_sup)

text ‹Theorem 46.3›

lemma diamond_right_sub_dist_sup:
  "|x>y  |x>z  |x>(y  z)"
  by (metis d_dist_sup diamond_def le_iff_sup mult_left_sub_dist_sup)

text ‹Theorem 46.4›

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: diamond_def mult_assoc)

text ‹Theorem 46.4›

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using diamond_x_und diamond_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by auto

text ‹Theorem 46.6›

lemma diamond_d_export:
  "|d(x) * y>z = d(x) * |y>z"
  using diamond_d_y diamond_def mult_assoc by auto

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_d_y diamond_def by force

text ‹Theorem 46.1›

lemma diamond_left_isotone:
  "x  y  |x>z  |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

text ‹Theorem 46.1›

lemma diamond_right_isotone:
  "y  z  |x>y  |x>z"
  by (metis diamond_right_sub_dist_sup le_iff_sup le_sup_iff)

lemma diamond_isotone:
  "w  y  x  z  |w>x  |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

lemma diamond_left_upper_bound:
  "|x>y  |x  z>y"
  by (simp add: diamond_left_isotone)

lemma diamond_right_upper_bound:
  "|x>y  |x>(y  z)"
  by (simp add: diamond_right_isotone)

lemma diamond_lower_bound_right:
  "|x>(d(y) * d(z))  |x>d(y)"
  by (simp add: diamond_right_isotone d_mult_left_lower_bound)

lemma diamond_lower_bound_left:
  "|x>(d(y) * d(z))  |x>d(z)"
  using diamond_lower_bound_right d_commutative by force

text ‹Theorem 46.5›

lemma diamond_right_sub_dist_mult:
  "|x>(d(y) * d(z))  |x>d(y) * |x>d(z)"
  using diamond_lower_bound_left diamond_lower_bound_right d_mult_greatest_lower_bound diamond_def by force

text ‹Theorem 46.13›

lemma diamond_demodalisation_1:
  "d(x) * |y>z  Z  d(x) * y * d(z)  Z"
  by (metis d_weak_locality diamond_def mult_assoc)

text ‹Theorem 46.14›

lemma diamond_demodalisation_3:
  "|x>y  d(z)  x * d(y)  d(z) * x  Z"
  apply (rule iffI)
  apply (smt (verit) sup_commute sup_right_isotone d_below_one d_restrict diamond_def diamond_x_und mult_left_isotone mult_right_isotone mult_1_right order_trans)
  by (smt sup_commute sup_bot_left d_Z d_commutative d_dist_sup d_involutive d_mult_sub d_plus_left_upper_bound diamond_d_y diamond_def diamond_x_und le_iff_sup order_trans)

text ‹Theorem 46.6›

lemma diamond_d_export_2:
  "|d(x) * y>z = d(x) * |d(x) * y>z"
  by (metis diamond_d_export diamond_left_mult d_idempotent)

text ‹Theorem 46.7›

lemma diamond_d_promote:
  "|x * d(y)>z = |x * d(y)>(d(y) * z)"
  by (metis d_idempotent diamond_def mult_assoc)

text ‹Theorem 46.8›

lemma diamond_d_import_iff:
  "d(x)  |y>z  d(x)  |d(x) * y>z"
  by (metis diamond_d_export diamond_d_y d_order diamond_def order.eq_iff)

text ‹Theorem 46.9›

lemma diamond_d_import_iff_2:
  "d(x) * d(y)  |z>w  d(x) * d(y)  |d(y) * z>w"
  apply (rule iffI)
  apply (metis diamond_associative d_export d_mult_greatest_lower_bound diamond_def order.refl)
  by (metis diamond_d_y d_mult_greatest_lower_bound diamond_def mult_assoc)

end

class relative_box_semiring = relative_diamond_semiring + relative_antidomain_semiring + box +
  assumes box_def: "|x]y = a(x * a(y))"
begin

text ‹Theorem 47.1›

lemma box_diamond:
  "|x]y = a( |x>a(y))"
  by (simp add: box_def d_a_closed diamond_def)

text ‹Theorem 47.2›

lemma diamond_box:
  "|x>y = a( |x]a(y))"
  using box_def d_def d_mult_d diamond_def by auto

lemma box_x_bot:
  "|x]bot = a(x)"
  by (metis box_def mult_1_right one_def)

lemma box_x_1:
  "|x]1 = a(x * bot)"
  by (simp add: box_def)

lemma box_x_d:
  "|x]d(y) = a(x * a(y))"
  by (simp add: box_def d_a_closed)

lemma box_x_und:
  "|x]d(y) = |x]y"
  by (simp add: box_diamond d_a_closed)

lemma box_x_a:
  "|x]a(y) = a(x * y)"
  using a_mult_d box_def by auto

text ‹Theorem 47.15›

lemma box_bot_y:
  "|bot]y = 1"
  using box_def by auto

lemma box_1_y:
  "|1]y = d(y)"
  by (simp add: box_def d_def)

text ‹Theorem 47.16›

lemma box_1_d:
  "|1]d(y) = d(y)"
  by (simp add: box_1_y box_x_und)

lemma box_1_a:
  "|1]a(y) = a(y)"
  by (simp add: box_x_a)

lemma box_d_y:
  "|d(x)]y = a(x)  d(y)"
  using a_export_a box_def d_def by auto

lemma box_a_y:
  "|a(x)]y = d(x)  d(y)"
  by (simp add: a_mult_deMorgan_1 box_def)

text ‹Theorem 47.14›

lemma box_d_bot:
  "|d(x)]bot = a(x)"
  by (simp add: box_x_bot d_a_closed)

lemma box_a_bot:
  "|a(x)]bot = d(x)"
  by (simp add: box_x_bot d_def)

text ‹Theorem 47.15›

lemma box_d_1:
  "|d(x)]1 = 1"
  by (simp add: box_d_y d_one_one)

lemma box_a_1:
  "|a(x)]1 = 1"
  by (simp add: box_x_1)

text ‹Theorem 47.13›

lemma box_d_d:
  "|d(x)]d(y) = a(x)  d(y)"
  by (simp add: box_d_y box_x_und)

lemma box_a_d:
  "|a(x)]d(y) = d(x)  d(y)"
  by (simp add: box_a_y box_x_und)

lemma box_d_a:
  "|d(x)]a(y) = a(x)  a(y)"
  by (simp add: box_x_a a_export_d)

lemma box_a_a:
  "|a(x)]a(y) = d(x)  a(y)"
  by (simp add: box_a_y a_d_closed)

text ‹Theorem 47.15›

lemma box_d_d_same:
  "|d(x)]d(x) = 1"
  using box_x_d d_complement_zero by auto

lemma box_a_a_same:
  "|a(x)]a(x) = 1"
  by (simp add: box_def)

text ‹Theorem 47.16›

lemma box_d_below_box:
  "d(x)  |d(y)]d(x)"
  by (simp add: box_d_d)

lemma box_d_closed:
  "|x]y = d( |x]y)"
  by (simp add: a_d_closed box_def)

lemma box_deMorgan_1:
  "a( |x]y) = |x>a(y)"
  by (simp add: diamond_box box_def)

lemma box_deMorgan_2:
  "a( |x>y) = |x]a(y)"
  using box_x_a d_a_closed diamond_def by auto

text ‹Theorem 47.5›

lemma box_left_dist_sup:
  "|x  y]z = |x]z * |y]z"
  by (simp add: a_dist_sup box_def mult_right_dist_sup)

lemma box_right_dist_sup:
  "|x](y  z) = a(x * a(y) * a(z))"
  by (simp add: a_dist_sup box_def mult_assoc)

lemma box_associative:
  "|x * y]z = a(x * y * a(z))"
  by (simp add: box_def)

text ‹Theorem 47.6›

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_a box_def mult_assoc by force

lemma box_right_mult:
  "|x](y * z) = a(x * a(y * z))"
  by (simp add: box_def)

text ‹Theorem 47.7›

lemma box_right_submult_d_d:
  "|x](d(y) * d(z))  |x]d(y) * |x]d(z)"
  by (smt a_antitone a_dist_sup a_export_d box_diamond d_a_closed diamond_def mult_left_sub_dist_sup)

lemma box_right_submult_a_d:
  "|x](a(y) * d(z))  |x]a(y) * |x]d(z)"
  by (metis box_right_submult_d_d a_d_closed)

lemma box_right_submult_d_a:
  "|x](d(y) * a(z))  |x]d(y) * |x]a(z)"
  using box_right_submult_a_d box_x_a d_def tests_dual.sub_commutative by auto

lemma box_right_submult_a_a:
  "|x](a(y) * a(z))  |x]a(y) * |x]a(z)"
  by (metis box_right_submult_d_d a_d_closed)

text ‹Theorem 47.8›

lemma box_d_export:
  "|d(x) * y]z = a(x)  |y]z"
  by (simp add: a_export_d box_def mult_assoc)

lemma box_a_export:
  "|a(x) * y]z = d(x)  |y]z"
  using box_a_y box_d_closed box_left_mult by auto

text ‹Theorem 47.4›

lemma box_left_antitone:
  "y  x  |x]z  |y]z"
  by (metis a_antitone box_def mult_left_isotone)

text ‹Theorem 47.3›

lemma box_right_isotone:
  "y  z  |x]y  |x]z"
  by (metis a_antitone box_def mult_right_isotone)

lemma box_antitone_isotone:
  "y  w  x  z  |w]x  |y]z"
  by (meson box_left_antitone box_right_isotone order_trans)

lemma diamond_1_a:
  "|1>a(y) = a(y)"
  by (simp add: d_def diamond_1_y)

lemma diamond_a_y:
  "|a(x)>y = a(x) * d(y)"
  by (metis a_d_closed diamond_d_y)

lemma diamond_a_bot:
  "|a(x)>bot = bot"
  by (simp add: diamond_a_y d_zero)

lemma diamond_a_1:
  "|a(x)>1 = a(x)"
  by (simp add: d_def diamond_x_1)

lemma diamond_a_d:
  "|a(x)>d(y) = a(x) * d(y)"
  by (simp add: diamond_a_y diamond_x_und)

lemma diamond_d_a:
  "|d(x)>a(y) = d(x) * a(y)"
  by (simp add: a_d_closed diamond_d_y)

lemma diamond_a_a:
  "|a(x)>a(y) = a(x) * a(y)"
  by (simp add: a_mult_closed diamond_def)

lemma diamond_a_a_same:
  "|a(x)>a(x) = a(x)"
  by (simp add: diamond_a_a)

lemma diamond_a_export:
  "|a(x) * y>z = a(x) * |y>z"
  using diamond_a_y diamond_associative diamond_def by auto

lemma a_box_a_a:
  "a(p) * |a(p)]a(q) = a(p) * a(q)"
  using box_a_a box_a_bot box_x_bot tests_dual.sup_complement_intro by auto

lemma box_left_lower_bound:
  "|x  y]z  |x]z"
  by (simp add: box_left_antitone)

lemma box_right_upper_bound:
  "|x]y  |x](y  z)"
  by (simp add: box_right_isotone)

lemma box_lower_bound_right:
  "|x](d(y) * d(z))  |x]d(y)"
  by (simp add: box_right_isotone d_mult_left_lower_bound)

lemma box_lower_bound_left:
  "|x](d(y) * d(z))  |x]d(z)"
  by (simp add: box_right_isotone d_restrict_iff_1)

text ‹Theorem 47.9›

lemma box_d_import:
  "d(x) * |y]z = d(x) * |d(x) * y]z"
  using a_box_a_a box_left_mult box_def d_def by force

text ‹Theorem 47.10›

lemma box_d_promote:
  "|x * d(y)]z = |x * d(y)](d(y) * z)"
  using a_box_a_a box_x_a box_def d_def mult_assoc by auto

text ‹Theorem 47.11›

lemma box_d_import_iff:
  "d(x)  |y]z  d(x)  |d(x) * y]z"
  using box_d_export box_def d_def tests_dual.shunting by auto

text ‹Theorem 47.12›

lemma box_d_import_iff_2:
  "d(x) * d(y)  |z]w  d(x) * d(y)  |d(y) * z]w"
  apply (rule iffI)
  using box_d_export le_supI2 apply simp
  by (metis box_d_import d_commutative d_restrict_iff_1)

text ‹Theorem 47.20›

lemma box_demodalisation_2:
  "-p  |y](-q)  -p * y * --q  Z"
  by (simp add: a_greatest_left_absorber box_def mult_assoc)

lemma box_right_sub_dist_sup:
  "|x]d(y)  |x]d(z)  |x](d(y)  d(z))"
  by (simp add: box_right_isotone)

lemma box_diff_var:
  "|x](d(y)  a(z)) * |x]d(z)  |x]d(z)"
  by (simp add: box_right_dist_sup box_x_d tests_dual.upper_bound_right)

text ‹Theorem 47.19›

lemma diamond_demodalisation_2:
  "|x>y  d(z)  a(z) * x * d(y)  Z"
  using a_antitone a_greatest_left_absorber a_mult_d d_def diamond_def mult_assoc by fastforce

text ‹Theorem 47.17›

lemma box_below_Z:
  "( |x]y) * x * a(y)  Z"
  by (simp add: a_restrict box_def mult_assoc)

text ‹Theorem 47.18›

lemma box_partial_correctness:
  "|x]1 = 1  x * bot  Z"
  by (simp add: box_x_1 a_strict)

lemma diamond_split:
  "|x>y = d(z) * |x>y  a(z) * |x>y"
  by (metis d_def diamond_def sup_monoid.add_commute tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)

lemma box_import_shunting:
  "-p * -q  |x](-r)  -q  |-p * x](-r)"
  by (smt box_demodalisation_2 mult_assoc sub_comm sub_mult_closed)

(*
lemma box_dist_mult: "|x](d(y) * d(z)) = |x](d(y)) * |x](d(z))" nitpick [expect=genuine,card=6] oops
lemma box_demodalisation_3: "d(x) ≤ |y]d(z) ⟶ d(x) * y ≤ y * d(z) ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma fbox_diff: "|x](d(y) ⊔ a(z)) ≤ |x]y ⊔ a( |x]z)" nitpick [expect=genuine,card=6] oops
lemma diamond_diff: "|x>y * a( |x>z) ≤ |x>(d(y) * a(z))" nitpick [expect=genuine,card=6] oops
lemma diamond_diff_var: "|x>d(y) ≤ |x>(d(y) * a(z)) ⊔ |x>d(z)" nitpick [expect=genuine,card=6] oops
*)

end

class relative_left_zero_diamond_semiring = relative_diamond_semiring + relative_domain_semiring + idempotent_left_zero_semiring
begin

lemma diamond_right_dist_sup:
  "|x>(y  z) = |x>y  |x>z"
  by (simp add: d_dist_sup diamond_def mult_left_dist_sup)

end

class relative_left_zero_box_semiring = relative_box_semiring + relative_left_zero_antidomain_semiring
begin

subclass relative_left_zero_diamond_semiring ..

lemma box_right_mult_d_d:
  "|x](d(y) * d(z)) = |x]d(y) * |x]d(z)"
  using a_dist_sup box_d_a box_def d_def mult_left_dist_sup by auto

lemma box_right_mult_a_d:
  "|x](a(y) * d(z)) = |x]a(y) * |x]d(z)"
  by (metis box_right_mult_d_d a_d_closed)

lemma box_right_mult_d_a:
  "|x](d(y) * a(z)) = |x]d(y) * |x]a(z)"
  using box_right_mult_a_d box_def box_x_a d_def by auto

lemma box_right_mult_a_a:
  "|x](a(y) * a(z)) = |x]a(y) * |x]a(z)"
  using a_dist_sup box_def mult_left_dist_sup tests_dual.sub_sup_demorgan by force

lemma box_demodalisation_3:
  assumes "d(x)  |y]d(z)"
    shows "d(x) * y  y * d(z)  Z"
proof -
  have "d(x) * y * a(z)  Z"
    using assms a_greatest_left_absorber box_x_d d_def mult_assoc by auto
  thus ?thesis
    by (simp add: a_a_below case_split_right_sup d_def sup_commute mult_assoc)
qed

lemma fbox_diff:
  "|x](d(y)  a(z))  |x]y  a( |x]z)"
  by (smt (z3) a_compl_intro a_dist_sup a_mult_d a_plus_left_lower_bound sup_commute box_def d_def mult_left_dist_sup tests_dual.sba_dual.shunting)

lemma diamond_diff_var:
  "|x>d(y)  |x>(d(y) * a(z))  |x>d(z)"
  by (metis d_cancellation_1 diamond_right_dist_sup diamond_right_isotone sup_commute)

lemma diamond_diff:
  "|x>y * a( |x>z)  |x>(d(y) * a(z))"
  by (metis d_a_shunting d_involutive diamond_def diamond_diff_var diamond_x_und)

end

end

Theory Complete_Tests

(* Title:      Complete Tests
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Complete Tests›

theory Complete_Tests

imports Tests

begin

class complete_tests = tests + Sup + Inf +
  assumes sup_test: "test_set A  Sup A = --Sup A"
  assumes sup_upper: "test_set A  x  A  x  Sup A"
  assumes sup_least: "test_set A  (xA . x  -y)  Sup A  -y"
begin

lemma Sup_isotone:
  "test_set B  A  B  Sup A  Sup B"
  by (metis sup_least sup_test sup_upper test_set_closed subset_eq)

lemma mult_right_dist_sup:
  assumes "test_set A"
    shows "Sup A * -p = Sup { x * -p | x . x  A }"
proof -
  have 1: "test_set { x * -p | x . x  A }"
    by (simp add: assms mult_right_dist_test_set)
  have 2: "Sup { x * -p | x . x  A }  Sup A * -p"
    by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_sup_left_isotone sub_mult_closed sup_test sup_least sup_upper test_set_def)
  have "xA . x  --(--Sup { x * -p | x . x  A }  --p)"
  proof
    fix x
    assume 3: "x  A"
    hence "x * -p  --p  Sup { x * -p | x . x  A }  --p"
      using 1 by (smt (verit, del_insts) assms mem_Collect_eq tests_dual.sub_inf_left_isotone sub_mult_closed sup_upper test_set_def sup_test)
    thus "x  --(--Sup { x * -p | x . x  A }  --p)"
      using 1 3 by (smt (z3) assms tests_dual.inf_closed sub_comm test_set_def sup_test sub_mult_closed tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_left_isotone tests_dual.inf_absorb tests_dual.inf_less_eq_cases_3)
  qed
  hence "Sup A  --(--Sup { x * -p | x . x  A }  --p)"
    by (simp add: assms sup_least)
  hence "Sup A * -p  Sup { x * -p | x . x  A }"
    using 1 by (smt (z3) assms sup_test tests_dual.sba_dual.shunting tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.sub_sup_demorgan)
  thus ?thesis
    using 1 2 by (smt (z3) assms sup_test tests_dual.sba_dual.sub_sup_closed tests_dual.antisymmetric tests_dual.inf_demorgan tests_dual.inf_idempotent)
qed

lemma mult_left_dist_sup:
  assumes "test_set A"
  shows "-p * Sup A = Sup { -p * x | x . x  A }"
proof -
  have 1: "Sup A * -p = Sup { x * -p | x . x  A }"
    by (simp add: assms mult_right_dist_sup)
  have 2: "-p * Sup A = Sup A * -p"
    by (metis assms sub_comm sup_test)
  have "{ -p * x | x . x  A } = { x * -p | x . x  A }"
    by (metis assms test_set_def tests_dual.sub_commutative)
  thus ?thesis
    using 1 2 by simp
qed

definition Sum :: "(nat  'a)  'a"
  where "Sum f  Sup { f n | n::nat . True }"

lemma Sum_test:
  "test_seq t  Sum t = --Sum t"
  using Sum_def sup_test test_seq_test_set by auto

lemma Sum_upper:
  "test_seq t  t x  Sum t"
  using Sum_def sup_upper test_seq_test_set by auto

lemma Sum_least:
  "test_seq t  (n . t n  -p)  Sum t  -p"
  using Sum_def sup_least test_seq_test_set by force

lemma mult_right_dist_Sum:
  "test_seq t  (n . t n * -p  -q)  Sum t * -p  -q"
  by (smt (verit, del_insts) CollectD Sum_def sup_least sup_test test_seq_test_set test_set_def tests_dual.sba_dual.shunting_right tests_dual.sba_dual.sub_sup_closed)

lemma mult_left_dist_Sum:
  "test_seq t  (n . -p * t n  -q)  -p * Sum t  -q"
  by (smt (verit, del_insts) Sum_def mem_Collect_eq mult_left_dist_sup sub_mult_closed sup_least test_seq_test_set test_set_def)

lemma pSum_below_Sum:
  "test_seq t  pSum t m  Sum t"
  using Sum_test Sum_upper nat_test_def pSum_below_sum test_seq_def mult_right_dist_Sum by auto

lemma pSum_sup:
  assumes "test_seq t"
    shows "pSum t m = Sup { t i | i . i  {..<m} }"
proof -
  have 1: "test_set { t i | i . i  {..<m} }"
    using assms test_seq_test_set test_set_def by auto
  have "y{ t i | i . i  {..<m} } . y  --pSum t m"
    using assms pSum_test pSum_upper by force
  hence 2: "Sup { t i | i . i  {..<m} }  --pSum t m"
    using 1 by (simp add: sup_least)
  have "pSum t m  Sup { t i | i . i  {..<m} }"
  proof (induct m)
    case 0
    show ?case
      by (smt (verit, ccfv_SIG) Collect_empty_eq empty_iff lessThan_0 pSum.simps(1) sup_test test_set_def tests_dual.top_greatest)
  next
    case (Suc n)
    have 4: "test_set {t i |i. i  {..<n}}"
      using assms test_seq_def test_set_def by auto
    have 5: "test_set {t i |i. i < Suc n}"
      using assms test_seq_def test_set_def by force
    hence 6: "Sup {t i |i. i < Suc n} = --Sup {t i |i. i < Suc n}"
      using sup_test by auto
    hence "x{t i |i. i  {..<n}} . x  --Sup {t i |i. i < Suc n}"
      using 5 less_Suc_eq sup_upper by fastforce
    hence 7: "Sup {t i |i. i  {..<n}}  --Sup {t i |i. i < Suc n}"
      using 4 by (simp add: sup_least)
    have "t n  {t i |i. i < Suc n}"
      by auto
    hence "t n  Sup {t i |i. i < Suc n}"
      using 5 by (simp add: sup_upper)
    hence "pSum t n  t n  Sup {t i |i. i <Suc n}"
      using Suc 4 6 7 by (smt assms tests_dual.greatest_lower_bound test_seq_def pSum_test tests_dual.sba_dual.transitive sup_test)
    thus ?case
      by simp
  qed
  thus ?thesis
    using 1 2 by (smt assms tests_dual.antisymmetric sup_test pSum_test)
qed

definition Prod :: "(nat  'a)  'a"
  where "Prod f  Inf { f n | n::nat . True }"

lemma Sum_range:
  "Sum f = Sup (range f)"
  by (simp add: Sum_def image_def)

lemma Prod_range:
  "Prod f = Inf (range f)"
  by (simp add: Prod_def image_def)

end

end

Theory Complete_Domain

(* Title:      Complete Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Complete Domain›

theory Complete_Domain

imports Relative_Domain Complete_Tests

begin

class complete_antidomain_semiring = relative_antidomain_semiring + complete_tests +
  assumes a_dist_Sum: "ascending_chain f  -(Sum f) = Prod (λn . -f n)"
  assumes a_dist_Prod: "descending_chain f  -(Prod f) = Sum (λn . -f n)"
begin

lemma a_ascending_chain:
  "ascending_chain f  descending_chain (λn . -f n)"
  by (simp add: a_antitone ascending_chain_def descending_chain_def)

lemma a_descending_chain:
  "descending_chain f  ascending_chain (λn . -f n)"
  by (simp add: a_antitone ord.ascending_chain_def ord.descending_chain_def)

lemma d_dist_Sum:
  "ascending_chain f  d(Sum f) = Sum (λn . d(f n))"
  by (simp add: d_def a_ascending_chain a_dist_Prod a_dist_Sum)

lemma d_dist_Prod:
  "descending_chain f  d(Prod f) = Prod (λn . d(f n))"
  by (simp add: d_def a_dist_Sum a_dist_Prod a_descending_chain)

end

end

Theory Preconditions

(* Title:      Preconditions
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Preconditions›

theory Preconditions

imports Tests

begin

class pre =
  fixes pre :: "'a  'a  'a" (infixr "«" 55)

class precondition = tests + pre +
  assumes pre_closed: "x«-q = --(x«-q)"
  assumes pre_seq: "x*y«-q = x«y«-q"
  assumes pre_lower_bound_right: "x«-p*-q  x«-q"
  assumes pre_one_increasing: "-q  1«-q"
begin

text ‹Theorem 39.2›

lemma pre_sub_distr:
  "x«-p*-q  (x«-p)*(x«-q)"
  by (smt (z3) pre_closed pre_lower_bound_right tests_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.least_upper_bound)

text ‹Theorem 39.5›

lemma pre_below_one:
  "x«-p  1"
  by (metis pre_closed tests_dual.sub_bot_least)

lemma pre_lower_bound_left:
  "x«-p*-q  x«-p"
  using pre_lower_bound_right tests_dual.sub_commutative by fastforce

text ‹Theorem 39.1›

lemma pre_iso:
  "-p  -q  x«-p  x«-q"
  by (metis leq_def pre_lower_bound_right)

text ‹Theorem 39.4 and Theorem 40.9›

lemma pre_below_pre_one:
  "x«-p  x«1"
  using tests_dual.sba_dual.one_def pre_iso tests_dual.sub_bot_least by blast

text ‹Theorem 39.3›

lemma pre_seq_below_pre_one:
  "x*y«1  x«1"
  by (metis one_def pre_below_pre_one pre_closed pre_seq)

text ‹Theorem 39.6›

lemma pre_compose:
  "-p  x«-q  -q  y«-r  -p  x*y«-r"
  by (metis pre_closed pre_iso tests_dual.transitive pre_seq)

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_test = precondition +
  assumes pre_test_test: "-p*(-p«-q) = -p*-q"
begin

lemma pre_one:
  "1«-p = -p"
  by (metis pre_closed pre_test_test tests_dual.sba_dual.one_def tests_dual.sup_left_unit)

lemma pre_import:
  "-p*(x«-q) = -p*(-p*x«-q)"
  by (metis pre_closed pre_seq pre_test_test)

lemma pre_import_composition:
  "-p*(-p*x*y«-q) = -p*(x«y«-q)"
  by (metis pre_closed pre_seq pre_import)

lemma pre_import_equiv:
  "-p  x«-q  -p  -p*x«-q"
  by (metis leq_def pre_closed pre_import)

lemma pre_import_equiv_mult:
  "-p*-q  x«-s  -p*-q  -q*x«-s"
  by (smt leq_def pre_closed sub_assoc sub_mult_closed pre_import)

(*
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_promote = precondition +
  assumes pre_test_promote: "-p«-q = -p«-p*-q"
begin

lemma pre_mult_test_promote:
  "x*-p«-q = x*-p«-p*-q"
  by (metis pre_seq pre_test_promote sub_mult_closed)

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_box = precondition +
  assumes pre_test: "-p«-q = --p-q"
begin

lemma pre_test_neg:
  "--p*(-p«-q) = --p"
  by (simp add: pre_test)

lemma pre_bot:
  "bot«-q = 1"
  by (metis pre_test tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_left_zero tests_dual.top_double_complement)

lemma pre_export:
  "-p*x«-q = --p(x«-q)"
  by (metis pre_closed pre_seq pre_test)

lemma pre_neg_mult:
  "--p  -p*x«-q"
  by (metis leq_def pre_closed pre_seq pre_test_neg)

lemma pre_test_test_same:
  "-p«-p = 1"
  using pre_test tests_dual.sba_dual.less_eq_sup_top tests_dual.sba_dual.reflexive by auto

lemma test_below_pre_test_mult:
  "-q  -p«-p*-q"
  by (metis pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.shunting tests_dual.sub_sup_closed)

lemma test_below_pre_test:
  "-q  -p«-q"
  by (simp add: pre_test tests_dual.sba_dual.upper_bound_right)

lemma test_below_pre_test_2:
  "--p  -p«-q"
  by (simp add: pre_test tests_dual.sba_dual.upper_bound_left)

lemma pre_test_bot:
  "-p«bot = --p"
  by (metis pre_test tests_dual.sba_dual.sup_right_unit tests_dual.top_double_complement)

lemma pre_test_one:
  "-p«1 = 1"
  by (metis pre_seq pre_bot tests_dual.sup_right_zero)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: pre_test tests_dual.sup_complement_intro)

subclass precondition_promote
  apply unfold_locales
  by (metis pre_test tests_dual.sba_dual.sub_commutative tests_dual.sub_sup_closed tests_dual.inf_complement_intro)

(*
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_test_diamond = precondition +
  assumes pre_test: "-p«-q = -p*-q"
begin

lemma pre_test_neg:
  "--p*(-p«-q) = bot"
  by (simp add: pre_test tests_dual.sub_associative tests_dual.sub_commutative)

lemma pre_bot:
  "bot«-q = bot"
  by (metis pre_test tests_dual.sup_left_zero tests_dual.top_double_complement)

lemma pre_export:
  "-p*x«-q = -p*(x«-q)"
  by (metis pre_closed pre_seq pre_test)

lemma pre_neg_mult:
  "-p*x«-q  -p"
  by (metis pre_closed pre_export tests_dual.upper_bound_left)

lemma pre_test_test_same:
  "-p«-p = -p"
  by (simp add: pre_test)

lemma test_above_pre_test_plus:
  "--p«-p-q  -q"
  using pre_test tests_dual.sba_dual.inf_complement_intro tests_dual.sub_commutative tests_dual.sub_inf_def tests_dual.upper_bound_left by auto

lemma test_above_pre_test:
  "-p«-q  -q"
  by (simp add: pre_test tests_dual.upper_bound_right)

lemma test_above_pre_test_2:
  "-p«-q  -p"
  by (simp add: pre_test tests_dual.upper_bound_left)

lemma pre_test_bot:
  "-p«bot = bot"
  by (metis pre_test tests_dual.sup_right_zero tests_dual.top_double_complement)

lemma pre_test_one:
  "-p«1 = -p"
  by (metis pre_test tests_dual.complement_top tests_dual.sup_right_unit)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: pre_test tests_dual.sub_associative)

subclass precondition_promote
  apply unfold_locales
  by (metis pre_seq pre_test tests_dual.sup_idempotent)

(*
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=6] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_distr_mult = precondition +
  assumes pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)"
begin

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_plus: "x«-p⊔-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=2] oops
*)

end

class precondition_distr_plus = precondition +
  assumes pre_distr_plus: "x«-p-q = (x«-p)(x«-q)"
begin

(*
lemma pre_test_test: "-p*(-p«-q) = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test_promote: "-p«-q = -p«-p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = --p⊔-q" nitpick [expect=genuine,card=2] oops
lemma pre_test: "-p«-q = -p*-q" nitpick [expect=genuine,card=2] oops
lemma pre_distr_mult: "x«-p*-q = (x«-p)*(x«-q)" nitpick [expect=genuine,card=4] oops
*)

end

end

Theory Hoare

(* Title:      Hoare Calculus
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Hoare Calculus›

theory Hoare

imports Complete_Tests Preconditions

begin

class ite =
  fixes ite :: "'a  'a  'a  'a" ("_  _  _" [58,58,58] 57)

class hoare_triple =
  fixes hoare_triple :: "'a  'a  'a  bool" ("_  _  _" [54,54,54] 53)

class ifthenelse = precondition + ite +
  assumes ite_pre: "x-py«-q = -p*(x«-q)  --p*(y«-q)"
begin

text ‹Theorem 40.2›

lemma ite_pre_then:
  "-p*(x-py«-q) = -p*(x«-q)"
proof -
  have "-p*(x-py«-q) = -p*(x«-q)  bot*(y«-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_commutative tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_1)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_left_zero)
qed

text ‹Theorem 40.3›

lemma ite_pre_else:
  "--p*(x-py«-q) = --p*(y«-q)"
proof -
  have "--p*(x-py«-q) = bot*(x«-q)  --p*(y«-q)"
    by (smt (z3) ite_pre pre_closed tests_dual.sub_commutative tests_dual.sub_inf_left_zero tests_dual.sup_left_zero tests_dual.sup_right_dist_inf tests_dual.top_double_complement tests_dual.wnf_lemma_3)
  thus ?thesis
    by (metis pre_closed tests_dual.sba_dual.sub_sup_demorgan tests_dual.sub_inf_left_zero tests_dual.sup_left_zero)
qed

lemma ite_import_mult_then:
  "-p*-q  x«-r  -p*-q  x-py«-r"
  by (smt ite_pre_then leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

lemma ite_import_mult_else:
  "--p*-q  y«-r  --p*-q  x-py«-r"
  by (smt ite_pre_else leq_def pre_closed sub_assoc sub_comm sub_mult_closed)

text ‹Theorem 40.1›

lemma ite_import_mult:
  "-p*-q  x«-r  --p*-q  y«-r  -q  x-py«-r"
  by (smt (verit) ite_import_mult_else ite_import_mult_then pre_closed tests_dual.sba_dual.inf_less_eq_cases)

end

class whiledo = ifthenelse + while +
  assumes while_pre: "-px«-q = -p*(x«-px«-q)  --p*-q"
  assumes while_post: "-px«-q = -px«--p*-q"
begin

text ‹Theorem 40.4›

lemma while_pre_then:
  "-p*(-px«-q) = -p*(x«-px«-q)"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_1)

text ‹Theorem 40.5›

lemma while_pre_else:
  "--p*(-px«-q) = --p*-q"
  by (smt pre_closed tests_dual.sub_commutative while_pre tests_dual.wnf_lemma_3)

text ‹Theorem 40.6›

lemma while_pre_sub_1:
  "-px«-q  x*(-px)-p1«-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing pre_seq tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_else while_pre_then)

text ‹Theorem 40.7›

lemma while_pre_sub_2:
  "-px«-q  x-p1«-px«-q"
  by (smt (z3) ite_import_mult pre_closed pre_one_increasing tests_dual.sba_dual.transitive tests_dual.sub_sup_closed tests_dual.upper_bound_right while_pre_then)

text ‹Theorem 40.8›

lemma while_pre_compl:
  "--p  -px«--p"
  by (metis pre_closed tests_dual.sup_idempotent tests_dual.upper_bound_right while_pre_else)

lemma while_pre_compl_one:
  "--p  -px«1"
  by (metis tests_dual.sba_dual.top_double_complement while_post tests_dual.sup_right_unit while_pre_compl)

text ‹Theorem 40.10›

lemma while_export_equiv:
  "-q  -px«1  -p*-q  -px«1"
  by (smt pre_closed tests_dual.sba_dual.shunting tests_dual.sba_dual.sub_less_eq_def tests_dual.sba_dual.top_double_complement while_pre_compl_one)

lemma nat_test_pre:
  assumes "nat_test t s"
      and "-q  s"
      and "n . t n*-p*-q  x«pSum t n*-q"
    shows "-q  -px«--p*-q"
proof -
  have 1: "-q*--p  -px«--p*-q"
    by (metis pre_closed tests_dual.sub_commutative while_post tests_dual.upper_bound_right while_pre_else)
  have "n . t n*-p*-q  -px«--p*-q"
  proof
    fix n
    show "t n*-p*-q  -px«--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      have 2: "t n = --(t n)"
        using assms(1) nat_test_def by auto
      assume "m<n . t m*-p*-q  -px«--p*-q"
      hence "m<n . t m*-p*-q  t m*--p*-q  -px«--p*-q"
        using 1 by (smt (verit, del_insts) assms(1) tests_dual.greatest_lower_bound leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
      hence "m<n . t m*-q  -px«--p*-q"
        by (smt (verit, del_insts) assms(1) tests_dual.sup_right_unit tests_dual.sup_left_dist_inf tests_dual.sup_right_dist_inf nat_test_def tests_dual.inf_complement sub_mult_closed)
      hence "pSum t n*-q  -px«--p*-q"
        by (smt assms(1) pSum_below_nat pre_closed sub_mult_closed)
      hence "t n*-p*-q*(-px«--p*-q) = t n*-p*-q"
        using 2 by (smt assms(1,3) leq_def pSum_test_nat pre_closed pre_sub_distr sub_assoc sub_comm sub_mult_closed transitive while_pre_then)
      thus "t n*-p*-q  -px«--p*-q"
        using 2 by (smt (z3) pre_closed tests_dual.sub_sup_closed tests_dual.upper_bound_right)
    qed
  qed
  hence "-q*-p  -px«--p*-q"
    by (smt (verit, del_insts) assms(1,2) leq_def nat_test_def pre_closed tests_dual.sub_associative tests_dual.sub_commutative sub_mult_closed)
  thus ?thesis
    using 1 by (smt (z3) pre_closed tests_dual.sba_dual.inf_less_eq_cases tests_dual.sub_commutative tests_dual.sub_sup_closed)
qed

lemma nat_test_pre_1:
  assumes "nat_test t s"
      and "-r  s"
      and "-r  -q"
      and "n . t n*-p*-q  x«pSum t n*-q"
    shows "-r  -px«--p*-q"
proof -
  let ?qs = "-q*s"
  have 1: "-r  ?qs"
    by (metis assms(1-3) nat_test_def tests_dual.least_upper_bound)
  have "n . t n*-p*?qs  x«pSum t n*?qs"
  proof
    fix n
    have 2: "pSum t n  s"
      by (simp add: assms(1) pSum_below_sum)
    have "t n = t n * s"
      by (metis assms(1) nat_test_def tests_dual.sba_dual.less_eq_inf)
    hence "t n*-p*?qs = t n*-p*-q"
      by (smt (verit, ccfv_threshold) assms(1) nat_test_def tests_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_commutative)
    also have "t n*-p*-q  x«pSum t n*-q"
      by (simp add: assms(4))
    also have "x«pSum t n*-q = x«pSum t n*?qs"
      using 2 by (smt (verit, ccfv_SIG) assms(1) leq_def nat_test_def pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
    finally show "t n*-p*?qs  x«pSum t n*?qs"
      .
  qed
  hence 3: "?qs  -px«--p*?qs"
    by (smt (verit, ccfv_threshold) assms(1) tests_dual.upper_bound_left tests_dual.upper_bound_right nat_test_def nat_test_pre pSum_test_nat pre_closed tests_dual.sub_associative sub_mult_closed transitive)
  have "-px«--p*?qs  -px«--p*-q"
    by (metis assms(1) nat_test_def pre_lower_bound_left tests_dual.sub_sup_closed while_post)
  thus ?thesis
    using 1 3 by (smt (verit, del_insts) leq_def tests_dual.sub_associative assms(1) nat_test_def pre_closed sub_mult_closed)
qed

lemma nat_test_pre_2:
  assumes "nat_test t s"
      and "-r  s"
      and "n . t n*-p  x«pSum t n"
    shows "-r  -px«1"
proof -
  have 1: "-r  -px«--p*s"
    by (smt (verit, ccfv_threshold) assms leq_def nat_test_def nat_test_pre_1 pSum_below_sum pSum_test_nat tests_dual.sub_associative tests_dual.sub_commutative)
  have "-px«--p*s  -px«1"
    by (metis assms(1) nat_test_def pre_below_pre_one while_post)
  thus ?thesis
    using 1 by (smt (verit) assms(1) nat_test_def pre_closed tests_dual.sba_dual.top_double_complement while_post tests_dual.transitive)
qed

lemma nat_test_pre_3:
  assumes "nat_test t s"
      and "-q  s"
      and "n . t n*-p*-q  x«pSum t n*-q"
    shows "-q  -px«1"
proof -
  have "-px«--p*-q  -px«1"
    by (metis pre_below_pre_one sub_mult_closed)
  thus ?thesis
    by (smt (verit, ccfv_threshold) assms pre_closed tests_dual.sba_dual.top_double_complement tests_dual.sba_dual.transitive tests_dual.sub_sup_closed nat_test_pre)
qed

definition aL :: "'a"
  where "aL  11«1"

lemma aL_test:
  "aL = --aL"
  by (metis aL_def one_def pre_closed)

end

class atoms = tests +
  fixes Atomic_program :: "'a set"
  fixes Atomic_test :: "'a set"
  assumes one_atomic_program: "1  Atomic_program"
  assumes zero_atomic_test: "bot  Atomic_test"
  assumes atomic_test_test: "p  Atomic_test  p = --p"

class while_program = whiledo + atoms + power
begin

inductive_set Test_expression :: "'a set"
  where atom_test: "p  Atomic_test  p  Test_expression"
      | neg_test:  "p  Test_expression  -p  Test_expression"
      | conj_test: "p  Test_expression  q  Test_expression  p*q  Test_expression"

lemma test_expression_test:
  "p  Test_expression  p = --p"
  apply (induct rule: Test_expression.induct)
  apply (simp add: atomic_test_test)
  apply simp
  by (metis tests_dual.sub_sup_closed)

lemma disj_test:
  "p  Test_expression  q  Test_expression  pq  Test_expression"
  by (smt conj_test neg_test tests_dual.sub_inf_def test_expression_test)

lemma zero_test_expression:
  "bot  Test_expression"
  by (simp add: Test_expression.atom_test zero_atomic_test)

lemma one_test_expression:
  "1  Test_expression"
  using Test_expression.simps tests_dual.sba_dual.one_def zero_test_expression by blast

lemma pSum_test_expression:
  "(n . t n  Test_expression)  pSum t m  Test_expression"
  apply (induct m)
  apply (simp add: zero_test_expression)
  by (simp add: disj_test)

inductive_set While_program :: "'a set"
  where atom_prog:  "x  Atomic_program  x  While_program"
      | seq_prog:   "x  While_program  y  While_program  x*y  While_program"
      | cond_prog:  "p  Test_expression  x  While_program  y  While_program  xpy  While_program"
      | while_prog: "p  Test_expression  x  While_program  px  While_program"

lemma one_while_program:
  "1  While_program"
  by (simp add: While_program.atom_prog one_atomic_program)

lemma power_while_program:
  "x  While_program  x^m  While_program"
  apply (induct m)
  apply (simp add: one_while_program)
  by (simp add: While_program.seq_prog)

inductive_set Pre_expression :: "'a set"
  where test_pre: "p  Test_expression  p  Pre_expression"
      | neg_pre:  "p  Pre_expression  -p  Pre_expression"
      | conj_pre: "p  Pre_expression  q  Pre_expression  p*q  Pre_expression"
      | pre_pre:  "p  Pre_expression  x  While_program  x«p  Pre_expression"

lemma pre_expression_test:
  "p  Pre_expression  p = --p"
  apply (induct rule: Pre_expression.induct)
  apply (simp add: test_expression_test)
  apply simp
  apply (metis sub_mult_closed)
  by (metis pre_closed)

lemma disj_pre:
  "p  Pre_expression  q  Pre_expression  pq  Pre_expression"
  by (smt conj_pre neg_pre tests_dual.sub_inf_def pre_expression_test)

lemma zero_pre_expression:
  "bot  Pre_expression"
  by (simp add: Pre_expression.test_pre zero_test_expression)

lemma one_pre_expression:
  "1  Pre_expression"
  by (simp add: Pre_expression.test_pre one_test_expression)

lemma pSum_pre_expression:
  "(n . t n  Pre_expression)  pSum t m  Pre_expression"
  apply (induct m)
  apply (simp add: zero_pre_expression)
  by (simp add: disj_pre)

lemma aL_pre_expression:
  "aL  Pre_expression"
  by (simp add: Pre_expression.pre_pre While_program.while_prog aL_def one_pre_expression one_test_expression one_while_program)

end

class hoare_calculus = while_program + complete_tests
begin

definition tfun :: "'a  'a  'a  'a  'a"
  where "tfun p x q r  p  (x«q*r)"

lemma tfun_test:
  "p = --p  q = --q  r = --r  tfun p x q r = --tfun p x q r"
  by (smt tfun_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun_pre_expression:
  "x  While_program  p  Pre_expression  q  Pre_expression  r  Pre_expression  tfun p x q r  Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun_def)

lemma tfun_iso:
  "p = --p  q = --q  r = --r  s = --s  r  s  tfun p x q r  tfun p x q s"
  by (smt tfun_def tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed tests_dual.sub_inf_right_isotone pre_closed)

definition tseq :: "'a  'a  'a  'a  nat  'a"
  where "tseq p x q r m  (tfun p x q ^ m) r"

lemma tseq_test:
  "p = --p  q = --q  r = --r  tseq p x q r m = --tseq p x q r m"
  apply (induct m)
  apply (smt tseq_def tfun_test power_zero_id id_def)
  by (metis tseq_def tfun_test power_succ_unfold_ext)

lemma tseq_test_seq:
  "p = --p  q = --q  r = --r  test_seq (tseq p x q r)"
  using test_seq_def tseq_test by auto

lemma tseq_pre_expression:
  "x  While_program  p  Pre_expression  q  Pre_expression  r  Pre_expression  tseq p x q r m  Pre_expression"
  apply (induct m)
  apply (smt tseq_def id_def power_zero_id)
  by (smt tseq_def power_succ_unfold_ext tfun_pre_expression)

definition tsum :: "'a  'a  'a  'a  'a"
  where "tsum p x q r  Sum (tseq p x q r)"

lemma tsum_test:
  "p = --p  q = --q  r = --r  tsum p x q r = --tsum p x q r"
  using Sum_test tseq_test_seq tsum_def by auto

lemma t_fun_test:
  "q = --q  tfun (-p) x (px«q) (-p(x«(px«q)*aL)) = --tfun (-p) x (px«q) (-p(x«(px«q)*aL))"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test)

lemma t_fun_pre_expression:
  "x  While_program  p  Test_expression  q  Pre_expression  tfun (-p) x (px«q) (-p(x«(px«q)*aL))  Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun_pre_expression)

lemma t_seq_test:
  "q = --q  tseq (-p) x (px«q) (-p(x«(px«q)*aL)) m = --tseq (-p) x (px«q) (-p(x«(px«q)*aL)) m"
  by (metis aL_test pre_closed tests_dual.sba_dual.double_negation tfun_def tfun_test tseq_test)

lemma t_seq_test_seq:
  "q = --q  test_seq (tseq (-p) x (px«q) (-p(x«(px«q)*aL)))"
  using test_seq_def t_seq_test by auto

lemma t_seq_pre_expression:
  "x  While_program  p  Test_expression  q  Pre_expression  tseq (-p) x (px«q) (-p(x«(px«q)*aL)) m  Pre_expression"
  using Pre_expression.pre_pre Pre_expression.test_pre Test_expression.neg_test While_program.while_prog aL_pre_expression tfun_def tfun_pre_expression tseq_pre_expression by auto

lemma t_sum_test:
  "q = --q  tsum (-p) x (px«q) (-p(x«(px«q)*aL)) = --tsum (-p) x (px«q) (-p(x«(px«q)*aL))"
  using Sum_test t_seq_test_seq tsum_def by auto

definition tfun2 :: "'a  'a  'a  'a  'a  'a"
  where "tfun2 p q x r s  p  q*(x«r*s)"

lemma tfun2_test:
  "p = --p  q = --q  r = --r  s = --s  tfun2 p q x r s = --tfun2 p q x r s"
  by (smt tfun2_def sub_mult_closed pre_closed tests_dual.inf_closed)

lemma tfun2_pre_expression:
  "x  While_program  p  Pre_expression  q  Pre_expression  r  Pre_expression  s  Pre_expression  tfun2 p q x r s  Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.pre_pre disj_pre tfun2_def)

lemma tfun2_iso:
  "p = --p  q = --q  r = --r  s1 = --s1  s2 = --s2  s1  s2  tfun2 p q x r s1  tfun2 p q x r s2"
  by (smt tfun2_def tests_dual.sub_inf_right_isotone pre_iso sub_mult_closed tests_dual.sub_sup_right_isotone pre_closed)

definition tseq2 :: "'a  'a  'a  'a  'a  nat  'a"
  where "tseq2 p q x r s m  (tfun2 p q x r ^ m) s"

lemma tseq2_test:
  "p = --p  q = --q  r = --r  s = --s  tseq2 p q x r s m = --tseq2 p q x r s m"
  apply (induct m)
  apply (smt tseq2_def power_zero_id id_def)
  by (smt tseq2_def tfun2_test power_succ_unfold_ext)

lemma tseq2_test_seq:
  "p = --p  q = --q  r = --r  s = --s  test_seq (tseq2 p q x r s)"
  using test_seq_def tseq2_test by force

lemma tseq2_pre_expression:
  "x  While_program  p  Pre_expression  q  Pre_expression  r  Pre_expression  s  Pre_expression  tseq2 p q x r s m  Pre_expression"
  apply (induct m)
  apply (smt tseq2_def id_def power_zero_id)
  by (smt tseq2_def power_succ_unfold_ext tfun2_pre_expression)

definition tsum2 :: "'a  'a  'a  'a  'a  'a"
  where "tsum2 p q x r s  Sum (tseq2 p q x r s)"

lemma tsum2_test:
  "p = --p  q = --q  r = --r  s = --s  tsum2 p q x r s = --tsum2 p q x r s"
  using Sum_test tseq2_test_seq tsum2_def by force

lemma t_fun2_test:
  "p = --p  q = --q  tfun2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) = --tfun2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test)

lemma t_fun2_pre_expression:
  "x  While_program  p  Test_expression  q  Pre_expression  tfun2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))  Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tfun2_pre_expression)

lemma t_seq2_test:
  "p = --p  q = --q  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m = --tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m"
  by (smt (z3) aL_test pre_closed tests_dual.sub_sup_closed tfun2_def tfun2_test tseq2_test)

lemma t_seq2_test_seq:
  "p = --p  q = --q  test_seq (tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)))"
  using test_seq_def t_seq2_test by auto

lemma t_seq2_pre_expression:
  "x  While_program  p  Test_expression  q  Pre_expression  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m  Pre_expression"
  by (simp add: Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre tseq2_pre_expression)

lemma t_sum2_test:
  "p = --p  q = --q  tsum2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) = --tsum2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))"
  using Sum_test t_seq2_test_seq tsum2_def by auto

lemma t_seq2_below_t_seq:
  assumes "p  Test_expression"
      and "q  Pre_expression"
    shows "tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m  tseq (-p) x (px«q) (-p(x«(px«q)*aL)) m"
proof -
  let ?t2 = "tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))"
  let ?t = "tseq (-p) x (px«q) (-p(x«(px«q)*aL))"
  show "?thesis"
  proof (induct m)
    case 0
    show "?t2 0  ?t 0"
      by (smt assms aL_test id_def tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_zero_id pre_closed pre_expression_test sub_mult_closed test_pre tseq2_def tseq_def)
  next
    fix m
    assume "?t2 m  ?t m"
    hence 1: "?t2 (Suc m)  tfun2 (- p * q) p x (p  x « q) (?t m)"
      by (smt assms power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq2_test t_seq_test test_pre tfun2_iso tseq2_def)
    have "...  ?t (Suc m)"
      by (smt assms tests_dual.upper_bound_left tests_dual.upper_bound_right tests_dual.inf_isotone power_succ_unfold_ext pre_closed pre_expression_test sub_mult_closed t_seq_test test_pre tfun2_def tfun_def tseq_def)
    thus "?t2 (Suc m)  ?t (Suc m)"
      using 1 by (smt (verit, del_insts) assms pre_closed pre_expression_test test_expression_test tests_dual.sba_dual.transitive tests_dual.sub_sup_closed t_seq2_test t_seq_test tfun2_test)
  qed
qed

lemma t_seq2_below_t_sum:
  "p  Test_expression  q  Pre_expression  x  While_program  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m  tsum (-p) x (px«q) (-p(x«(px«q)*aL))"
   by (smt (verit, del_insts) Sum_upper pre_expression_test t_seq2_below_t_seq t_seq2_test t_seq_test t_sum_test test_pre test_seq_def tsum_def leq_def tests_dual.sub_associative)

lemma t_sum2_below_t_sum:
  "p  Test_expression  q  Pre_expression  x  While_program  tsum2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))  tsum (-p) x (px«q) (-p(x«(px«q)*aL))"
  by (smt Sum_least pre_expression_test t_seq2_below_t_sum t_seq2_test t_sum_test test_pre test_seq_def tsum2_def)

lemma t_seq2_below_w:
  "p  Test_expression  q  Pre_expression  x  While_program  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m  px«q"
  apply (cases m)
  apply (smt aL_test id_def tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone power_zero_id pre_closed pre_expression_test pre_iso sub_mult_closed test_pre tseq2_def while_pre)
  by (smt tseq2_def power_succ_unfold_ext tests_dual.upper_bound_left tests_dual.sub_sup_right_isotone tests_dual.inf_commutative tests_dual.sub_inf_right_isotone pre_closed pre_expression_test pre_iso sub_mult_closed t_seq2_test test_pre tseq2_def while_pre tfun2_def)

lemma t_sum2_below_w:
  "p  Test_expression  q  Pre_expression  x  While_program  tsum2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL))  px«q"
  by (smt Sum_least pre_closed pre_expression_test t_seq2_below_w t_seq2_test_seq test_pre tsum2_def)

lemma t_sum2_w:
  assumes "aL = 1"
      and "p  Test_expression"
      and "q  Pre_expression"
      and "x  While_program"
    shows "tsum2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) = px«q"
proof -
  let ?w = "px«q"
  let ?s = "-p*qp*(x«?w*aL)"
  have "?w = tseq2 (-p*q) p x ?w ?s 0"
    by (smt assms(1-3) tests_dual.sup_right_unit id_def tests_dual.inf_commutative power_zero_id pre_closed pre_expression_test sub_mult_closed test_expression_test tseq2_def while_pre)
  hence "?w  tsum2 (-p*q) p x ?w ?s"
    by (smt assms(2,3) Sum_upper pre_expression_test t_seq2_test_seq test_pre tsum2_def)
  thus ?thesis
    by (smt assms(2-4) tests_dual.antisymmetric pre_closed pre_expression_test t_sum2_test t_sum2_below_w test_pre)
qed

inductive derived_hoare_triple :: "'a  'a  'a  bool" ("_  _  _" [54,54,54] 53)
  where atom_trip:  "p  Pre_expression  x  Atomic_program  x«pxp"
      | seq_trip:   "pxq  qyr  px*yr"
      | cond_trip:  "p  Test_expression  q  Pre_expression  p*qxr  -p*qyr  qxpyr"
      | while_trip: "p  Test_expression  q  Pre_expression  test_seq t  q  Sum t  t 0*p*qxaL*q  (n>0 . t n*p*qxpSum t n*q)  qpx-p*q"
      | cons_trip:  "p  Pre_expression  s  Pre_expression  p  q  qxr  r  s  pxs"

lemma derived_type:
  "pxq  p  Pre_expression  q  Pre_expression  x  While_program"
  apply (induct rule: derived_hoare_triple.induct)
  apply (simp add: Pre_expression.pre_pre While_program.atom_prog)
  using While_program.seq_prog apply blast
  using While_program.cond_prog apply blast
  using Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog apply simp
  by blast

lemma cons_pre_trip:
  "p  Pre_expression  qyr  p*qyr"
  by (metis cons_trip derived_type Pre_expression.conj_pre pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

lemma cons_post_trip:
  "q  Pre_expression  r  Pre_expression  pyq*r  pyr"
  by (metis cons_trip derived_type pre_expression_test tests_dual.sba_dual.reflexive tests_dual.upper_bound_right)

definition valid_hoare_triple :: "'a  'a  'a  bool" ("_  _  _" [54,54,54] 53)
  where "pxq  (p  Pre_expression  q  Pre_expression  x  While_program  p  x«q)"

end

class hoare_calculus_sound = hoare_calculus +
  assumes while_soundness: "-p*-q  x«-q  aL*-q  -px«-q"
begin

lemma while_soundness_0:
  "-p*-q  x«-q  -q*aL  -px«--p*-q"
  by (smt while_soundness aL_test sub_comm while_post)

lemma while_soundness_1:
  assumes "test_seq t"
      and "-q  Sum t"
      and "t 0*-p*-q  x«aL*-q"
      and "n>0 . t n*-p*-q  x«pSum t n*-q"
    shows "-q  -px«--p*-q"
proof -
  have "n . t n*-p*-q  x«-q"
  proof
    fix n
    show "t n*-p*-q  x«-q"
    proof (cases n)
      case 0
      thus ?thesis
        by (smt (z3) assms(1) assms(3) aL_test leq_def pre_closed pre_lower_bound_right test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
    next
      case (Suc m)
      hence 1: "t n*-p*-q  x«pSum t n*-q"
        using assms(4) by blast
      have "x«pSum t n*-q  x«-q"
        by (metis assms(1) pSum_test pre_lower_bound_right)
      thus ?thesis
        using 1 by (smt (verit, del_insts) assms(1) pSum_test pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
    qed
  qed
  hence 2: "-p*-q  x«-q"
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_assoc sub_comm sub_mult_closed test_seq_def)
  have "n . t n*-q  -px«--p*-q  pSum t n*-q  -px«--p*-q"
  proof
    fix n
    show "t n*-q  -px«--p*-q  pSum t n*-q  -px«--p*-q"
    proof (induct n rule: nat_less_induct)
      fix n
      assume 3: "m<n . t m*-q  -px«--p*-q  pSum t m*-q  -px«--p*-q"
      have 4: "pSum t n*-q  -px«--p*-q"
      proof (cases n)
        case 0
        thus ?thesis
          by (metis pSum.simps(1) pre_closed sub_mult_closed tests_dual.top_greatest tests_dual.sba_dual.less_eq_inf tests_dual.top_double_complement)
      next
        case (Suc m)
        hence "pSum t n*-q = (pSum t m  t m)*-q"
          by simp
        also have "... = pSum t m*-q  t m*-q"
          by (metis (full_types) assms(1) pSum_test test_seq_def tests_dual.sup_right_dist_inf)
        also have "...  -px«--p*-q"
        proof -
          have "pSum t m*-q = --(pSum t m*-q)  t m*-q = --(t m*-q)  -px«--p*-q = --(-px«--p*-q)"
            apply (intro conjI)
            apply (metis assms(1) pSum_test tests_dual.sub_sup_closed)
            apply (metis assms(1) test_seq_def tests_dual.sub_sup_closed)
            by (metis pre_closed tests_dual.sub_sup_closed)
          thus ?thesis
            using 3 by (smt (z3) lessI Suc tests_dual.greatest_lower_bound sub_mult_closed)
        qed
        finally show ?thesis
          .
      qed
      hence 5: "x«pSum t n*-q  x«-px«--p*-q"
        by (smt assms pSum_test pre_closed pre_iso sub_mult_closed)
      have 6: "-p*(t n*-q)  -p*(-px«--p*-q)"
      proof (cases n)
        case 0
        thus ?thesis
          using 2 by (smt assms(1,3) aL_test leq_def tests_dual.sup_idempotent tests_dual.sub_sup_right_isotone pre_closed pre_lower_bound_left sub_assoc sub_comm sub_mult_closed test_seq_def transitive while_pre_then while_soundness_0)
      next
        case (Suc m)
        hence "-p*(t n*-q)  x«pSum t n*-q"
          by (smt assms(1,4) test_seq_def tests_dual.sub_associative tests_dual.sub_commutative zero_less_Suc)
        hence "-p*(t n*-q)  x«-px«--p*-q"
          using 5 by (smt assms(1) tests_dual.least_upper_bound pSum_test pre_closed sub_mult_closed test_seq_def leq_def)
        hence "-p*(t n*-q)  -p*(x«-px«--p*-q)"
          by (smt assms(1) tests_dual.upper_bound_left pre_closed sub_mult_closed test_seq_def leq_def tests_dual.sub_associative)
        thus ?thesis
          using while_post while_pre_then by auto
      qed
      have "--p*(t n*-q)  --p*(-px«--p*-q)"
        by (smt assms(1) leq_def tests_dual.upper_bound_right sub_assoc sub_comm sub_mult_closed test_seq_def while_pre_else)
      thus "t n*-q  -px«--p*-q  pSum t n*-q  -px«--p*-q"
        using 4 6 by (smt assms(1) tests_dual.sup_less_eq_cases_2 pre_closed sub_mult_closed test_seq_def)
    qed
  qed
  thus ?thesis
    by (smt assms(1,2) Sum_test leq_def mult_right_dist_Sum pre_closed sub_comm sub_mult_closed)
qed

lemma while_soundness_2:
  assumes "test_seq t"
      and "-r  Sum t"
      and "n . t n*-p  x«pSum t n"
    shows "-r  -px«1"
proof -
  have 1: "n>0 . t n*-p*Sum t  x«pSum t n*Sum t"
    by (smt (z3) assms(1,3) Sum_test Sum_upper leq_def pSum_below_Sum pSum_test test_seq_def tests_dual.sub_associative tests_dual.sub_commutative)
  have 2: "t 0*-p*Sum t  x«bot"
    by (smt assms(1,3) Sum_test Sum_upper leq_def sub_assoc sub_comm test_seq_def pSum.simps(1))
  have "x«bot  x«aL*Sum t"
    by (smt assms(1) Sum_test aL_test pre_iso sub_mult_closed tests_dual.top_double_complement tests_dual.top_greatest)
  hence "t 0*-p*Sum t  x«aL*Sum t"
    using 2 by (smt (z3) assms(1) Sum_test aL_test leq_def pSum.simps(1) pSum_test pre_closed test_seq_def tests_dual.sub_associative tests_dual.sub_sup_closed)
  hence 3: "Sum t  -px«--p*Sum t"
    using 1 by (smt (verit, del_insts) assms(1) Sum_test tests_dual.sba_dual.one_def tests_dual.sup_right_unit tests_dual.upper_bound_left while_soundness_1)
  have "-px«--p*Sum t  -px«1"
    by (metis assms(1) Sum_test pre_below_pre_one tests_dual.sub_sup_closed)
  hence "Sum t  -px«1"
    using 3 by (smt (z3) assms(1) Sum_test pre_closed tests_dual.sba_dual.one_def while_post tests_dual.transitive)
  thus ?thesis
    by (smt (z3) assms(1,2) Sum_test pre_closed tests_dual.sba_dual.one_def tests_dual.transitive)
qed

theorem soundness:
  "pxq  pxq"
  apply (induct rule: derived_hoare_triple.induct)
  apply (metis Pre_expression.pre_pre While_program.atom_prog pre_expression_test tests_dual.sba_dual.reflexive valid_hoare_triple_def)
  apply (metis valid_hoare_triple_def pre_expression_test pre_compose While_program.seq_prog)
  apply (metis valid_hoare_triple_def ite_import_mult pre_expression_test cond_prog test_pre)
  apply (smt (verit, del_insts) Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.test_pre While_program.while_prog pre_expression_test valid_hoare_triple_def while_soundness_1)
  by (metis pre_expression_test pre_iso pre_pre tests_dual.sba_dual.transitive valid_hoare_triple_def)

end

class hoare_calculus_pre_complete = hoare_calculus +
  assumes aL_pre_import: "(x«-q)*aL  x«-q*aL"
  assumes pre_right_dist_Sum: "x  While_program  ascending_chain t  test_seq t  x«Sum t = Sum (λn . x«t n)"
begin

lemma aL_pre_import_equal:
  "(x«-q)*aL = (x«-q*aL)*aL"
proof -
  have 1: "(x«-q)*aL  (x«-q*aL)*aL"
    by (smt (z3) aL_pre_import aL_test pre_closed tests_dual.sub_sup_closed tests_dual.least_upper_bound tests_dual.upper_bound_right)
  have "(x«-q*aL)*aL  (x«-q)*aL"
    by (smt (verit, ccfv_threshold) aL_test pre_closed pre_lower_bound_left tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive tests_dual.sub_sup_closed)
  thus ?thesis
    using 1 by (smt (z3) tests_dual.antisymmetric aL_test pre_closed tests_dual.sub_sup_closed)
qed

lemma aL_pre_below_t_seq2:
  assumes "p  Test_expression"
      and "q  Pre_expression"
    shows "(px«q)*aL  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) 0"
proof (unfold tseq2_def power_zero_id id_def while_pre)
  have "(px«q)*aL = (p*(x«px«q)  -p*q)*aL"
    by (metis assms while_pre test_pre pre_expression_test)
  also have "... = p*(x«px«q)*aL  -p*q*aL"
    by (smt (z3) assms aL_test tests_dual.sup_right_dist_inf pre_closed pre_expression_test sub_mult_closed test_pre)
  also have "... = p*((x«px«q)*aL)  -p*q*aL"
    by (smt assms aL_test pre_closed pre_expression_test test_pre sub_assoc)
  also have "...  p*(x«(px«q)*aL)  -p*q"
  proof -
    have 1: "(x«px«q)*aL  x«(px«q)*aL"
      by (metis assms(2) pre_closed pre_expression_test aL_pre_import)
    have "-p*q*aL  -p*q"
      by (metis assms(2) aL_test pre_expression_test tests_dual.sub_sup_closed tests_dual.upper_bound_left)
    thus ?thesis
      using 1 by (smt assms aL_test pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed tests_dual.sub_sup_right_isotone tests_dual.inf_isotone)
  qed
  also have "... = -p*q  p*(x«(px«q)*aL)"
    by (smt assms aL_test tests_dual.inf_commutative pre_closed pre_expression_test test_pre tests_dual.sub_sup_closed)
  finally show "(px«q)*aL  -p*q  p*(x«(px«q)*aL)"
    .
qed

lemma t_seq2_ascending:
  assumes "p  Test_expression"
      and "q  Pre_expression"
      and "x  While_program"
    shows "tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) m  tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)) (Suc m)"
proof (induct m)
  let ?w = "px«q"
  let ?r = "-p*qp*(x«?w*aL)"
  case 0
  have 1: "?w*aL = --(?w*aL)"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression pre_expression_test)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have "?w*aL  ?r"
    by (metis aL_pre_below_t_seq2 assms(1,2) id_def tseq2_def power_zero_id)
  hence "?w*aL  ?w*?r"
    using 1 2 by (smt (verit, ccfv_threshold) assms Pre_expression.pre_pre While_program.while_prog aL_test pre_expression_test tests_dual.sub_associative tests_dual.sub_sup_right_isotone tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive)
  hence "x«?w*aL  x«(?w*?r)"
    by (smt (verit, ccfv_threshold) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre)
  hence "p*(x«?w*aL)  p*(x«(?w*?r))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone)
  hence "?r  -p*qp*(x«(?w*?r))"
    by (smt (verit, del_insts) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone)
  thus ?case
    by (unfold tseq2_def power_zero_id power_succ_unfold_ext id_def tfun2_def)
next
  let ?w = "px«q"
  let ?r = "-p*qp*(x«?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  case (Suc m)
  hence "?w*?t m  ?w*?t (Suc m)"
    by (smt (z3) assms(1,2) pre_closed pre_expression_test t_seq2_test test_expression_test tests_dual.sub_sup_right_isotone)
  hence "x«?w*?t m  x«?w*?t (Suc m)"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test pre_iso test_pre tseq2_pre_expression)
  hence "p*(x«?w*?t m)  p*(x«?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sub_sup_right_isotone tseq2_pre_expression)
  hence "-p*qp*(x«?w*?t m)  -p*qp*(x«?w*?t (Suc m))"
    by (smt (z3) assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test test_pre tests_dual.sba_dual.reflexive tests_dual.inf_isotone tseq2_pre_expression)
  thus ?case
    by (smt tseq2_def power_succ_unfold_ext tfun2_def)
qed

lemma t_seq2_ascending_chain:
  "p  Test_expression  q  Pre_expression  x  While_program  ascending_chain (tseq2 (-p*q) p x (px«q) (-p*qp*(x«(px«q)*aL)))"
  by (simp add: ord.ascending_chain_def t_seq2_ascending)

end

class hoare_calculus_complete = hoare_calculus_pre_complete +
  assumes while_completeness: "-p*(x«-q)  -q  -px«-q  -qaL"
begin

lemma while_completeness_var:
  assumes "-p*(x«-q)-r  -q"
    shows "-px«-r  -qaL"
proof -
  have 1: "-px«-q  -qaL"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound while_completeness)
  have "-px«-r  -px«-q"
    by (smt assms pre_closed tests_dual.sub_sup_closed tests_dual.greatest_lower_bound pre_iso)
  thus ?thesis
    using 1 by (smt (z3) aL_test pre_closed tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.transitive)
qed

lemma while_completeness_sum:
  assumes "p  Test_expression"
      and "q  Pre_expression"
      and "x  While_program"
    shows "px«q  tsum (-p) x (px«q) (-p(x«(px«q)*aL))"
proof -
  let ?w = "px«q"
  let ?r = "-p*qp*(x«?w*aL)"
  let ?t = "tseq2 (-p*q) p x ?w ?r"
  let ?ts = "tsum2 (-p*q) p x ?w ?r"
  have 1: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have 2: "?r = --?r"
    by (simp add: assms Pre_expression.conj_pre Pre_expression.neg_pre Pre_expression.pre_pre Pre_expression.test_pre While_program.while_prog aL_pre_expression disj_pre pre_expression_test)
  have 3: "?ts = --?ts"
    by (meson assms(1) assms(2) pre_expression_test t_sum2_test test_expression_test)
  have 4: "test_seq ?t"
    by (simp add: assms(1) assms(2) pre_expression_test t_seq2_test_seq test_expression_test)
  have "-p*q  ?r"
    by (smt (z3) assms(1,2) aL_test pre_closed pre_expression_test sub_mult_closed test_pre tests_dual.lower_bound_left)
  hence 5: "-p*q  ?ts"
    using 1 2 3 by (smt assms Sum_upper id_def tests_dual.sba_dual.transitive power_zero_id pre_expression_test sub_mult_closed test_pre tseq2_def tseq2_test_seq tsum2_def)
  have "n . p*(x«?t n)  ?ts"
  proof (rule allI, unfold tsum2_def)
    fix n
    have 6: "p*(x«?t n)  ?t (Suc n)"
      using 4 by (smt assms leq_def power_succ_unfold_ext pre_closed pre_expression_test tests_dual.sub_commutative sub_mult_closed t_seq2_below_w test_pre test_seq_def tfun2_def tseq2_def tests_dual.lower_bound_right)
    have "?t (Suc n)  Sum ?t"
      using 4 Sum_upper by auto
    thus "p*(x«?t n)  Sum ?t"
      using 3 4 6 by (smt assms(1) pre_closed pre_expression_test sub_mult_closed test_pre test_seq_def tests_dual.transitive tsum2_def)
  qed
  hence "p*(x«?ts)  ?ts"
    using 3 4 by (smt assms mult_left_dist_Sum pre_closed pre_right_dist_Sum t_seq2_ascending_chain test_expression_test test_seq_def tsum2_def)
  hence "p*(x«?ts)-p*q  ?ts"
    using 3 5 by (smt assms(1,2) tests_dual.greatest_lower_bound pre_closed pre_expression_test sub_mult_closed test_pre)
  hence "?w  ?tsaL"
    using 1 3 by (smt assms(1,2) pre_expression_test while_post sub_mult_closed t_sum2_below_t_sum t_sum_test test_pre transitive while_completeness_var)
  hence "?w = ?w*(?tsaL)"
    using 1 3 by (smt aL_test tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.sub_sup_closed)
  also have "... = ?w*?ts?w*aL"
    using 1 3 by (smt aL_test tests_dual.sup_left_dist_inf)
  also have "...  ?ts?t 0"
    using 1 3 4 by (smt (z3) assms(1,2) aL_pre_below_t_seq2 tests_dual.upper_bound_right aL_test test_seq_def tests_dual.sub_sup_closed tests_dual.inf_isotone)
  also have "... = ?ts"
    using 3 4 by (smt Sum_upper tsum2_def test_seq_def tests_dual.less_eq_inf)
  finally have "?w  ?ts"
    .
  thus ?thesis
    using 1 3 by (metis assms t_sum2_below_t_sum t_sum2_below_w tests_dual.antisymmetric)
qed

lemma while_complete:
  assumes "p  Test_expression"
      and "q  Pre_expression"
      and "x  While_program"
      and "rPre_expression . x«rxr"
    shows "px«qpxq"
proof -
  let ?w = "px«q"
  let ?t = "tseq (-p) x ?w (-p(x«?w*aL))"
  have 1: "?w  Pre_expression"
    by (simp add: assms(1-3) Pre_expression.pre_pre While_program.while_prog)
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  hence 3: "?w  Sum ?t"
    using assms(1-3) tsum_def while_completeness_sum by auto
  have 4: "p = --p"
    by (simp add: assms(1) test_expression_test)
  have "x«?w*aL = --(x«?w*aL)"
    using 1 by (simp add: assms(3) Pre_expression.conj_pre Pre_expression.pre_pre aL_pre_expression pre_expression_test)
  hence 5: "(-p(x«?w*aL))*p = (x«?w*aL)*p"
    using 4 by (metis tests_dual.sba_dual.inf_complement_intro)
  have "x«aL*?wxaL*?w"
    using 1 by (simp add: assms(4) Pre_expression.conj_pre aL_pre_expression)
  hence "x«?w*aLxaL*?w"
    using 1 by (metis aL_test pre_expression_test sub_comm)
  hence "(x«?w*aL)*p*?wxaL*?w"
    using 1 by (smt (z3) assms(1) Pre_expression.conj_pre Pre_expression.test_pre derived_hoare_triple.cons_trip derived_type pre_expression_test sub_assoc tests_dual.sba_dual.reflexive tests_dual.upper_bound_left)
  hence "(-p(x«?w*aL))*p*?wxaL*?w"
    using 5 by simp
  hence 6: "?t 0*p*?wxaL*?w"
    by (unfold tseq_def power_zero_id id_def)
  have "n>0 . ?t n*p*?wxpSum ?t n*?w"
  proof (rule allI, rule impI)
    fix n
    assume "0<(n::nat)"
    from this obtain m where 7: "n = Suc m"
      by (auto dest: less_imp_Suc_add)
    hence "?t m*?w  pSum ?t n*?w"
      using 1 2 by (smt pSum.simps(2) pSum_test pre_expression_test test_seq_def tests_dual.lower_bound_right tests_dual.sba_dual.inf_isotone tests_dual.sba_dual.reflexive)
    thus "?t n*p*?wxpSum ?t n*?w"
      using 1 7 by (smt assms conj_pre cons_trip tests_dual.upper_bound_left tests_dual.sba_dual.inf_complement_intro pSum_pre_expression power_succ_unfold_ext pre_closed pre_expression_test sub_assoc sub_comm t_seq_pre_expression test_pre tfun_def tseq_def)
  qed
  hence "?wpx-p*?w"
    using 1 2 3 6 assms while_trip by auto
  hence "?wpx-p*q"
    using 4 by (metis assms(2) while_pre_else pre_expression_test while_pre_else)
  thus ?thesis
    using assms(1,2) Pre_expression.neg_pre Pre_expression.test_pre cons_post_trip by blast
qed

lemma pre_completeness:
  "x  While_program  q  Pre_expression  x«qxq"
  apply (induct arbitrary: q rule: While_program.induct)
  apply (simp add: derived_hoare_triple.atom_trip)
  apply (metis pre_pre pre_seq seq_trip pre_expression_test)
  apply (smt cond_prog cond_trip cons_pre_trip ite_pre_else ite_pre_then neg_pre pre_pre pre_expression_test test_pre)
  by (simp add: while_complete)

theorem completeness:
  "pxq  pxq"
  by (metis valid_hoare_triple_def pre_completeness tests_dual.reflexive pre_expression_test cons_trip)

end

class hoare_calculus_sound_complete = hoare_calculus_sound + hoare_calculus_complete
begin

text ‹Theorem 41›

theorem soundness_completeness:
  "pxq  pxq"
  using completeness soundness by blast

end

class hoare_rules = whiledo + complete_tests + hoare_triple +
  assumes rule_pre:   "x«-qx-q"
  assumes rule_seq:   "-px-q  -qy-r  -px*y-r"
  assumes rule_cond:  "-p*-qx-r  --p*-qy-r  -qx-py-r"
  assumes rule_while: "test_seq t  -q  Sum t  t 0*-p*-qxaL*-q  (n>0 . t n*-p*-qxpSum t n*-q)  -q-px--p*-q"
  assumes rule_cons:  "-p  -q  -qx-r  -r  -s  -px-s"
  assumes rule_disj:  "-px-r  -qx-s  -p-qx-r-s"
begin

lemma rule_cons_pre:
  "-p  -q  -qx-r  -px-r"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_pre_mult:
  "-qx-r  -p*-qx-r"
  by (metis tests_dual.sub_sup_closed rule_cons_pre tests_dual.upper_bound_right)

lemma rule_cons_pre_plus:
  "-p-qx-r  -px-r"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_pre)

lemma rule_cons_post:
  "-qx-r  -r  -s  -qx-s"
  using rule_cons tests_dual.sba_dual.reflexive by blast

lemma rule_cons_post_mult:
  "-qx-r*-s  -qx-s"
  by (metis rule_cons_post tests_dual.upper_bound_left sub_comm sub_mult_closed)

lemma rule_cons_post_plus:
  "-qx-r  -qx-r-s"
  by (metis tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left rule_cons_post)

lemma rule_disj_pre:
 "-px-r  -qx-r  -p-qx-r"
  by (metis rule_disj tests_dual.sba_dual.sup_idempotent)

end

class hoare_calculus_valid = hoare_calculus_sound_complete + hoare_triple +
  assumes hoare_triple_valid: "-px-q  -p  x«-q"
begin

lemma valid_hoare_triple_same:
  "p  Pre_expression  q  Pre_expression  x  While_program  pxq = pxq"
  by (metis valid_hoare_triple_def hoare_triple_valid pre_expression_test)

lemma derived_hoare_triple_same:
  "p  Pre_expression  q  Pre_expression  x  While_program  pxq = pxq"
  by (simp add: soundness_completeness valid_hoare_triple_same)

lemma valid_rule_disj:
  assumes "-px-r"
      and "-qx-s"
    shows "-p-qx-r-s"
proof -
  have "x«-r  x«-r-s  x«-s  x«-r-s"
    by (metis pre_iso tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.upper_bound_left tests_dual.sba_dual.upper_bound_right)
  thus ?thesis
    by (smt assms hoare_triple_valid tests_dual.greatest_lower_bound tests_dual.sba_dual.sub_sup_closed pre_closed tests_dual.transitive)
qed

subclass hoare_rules
  apply unfold_locales
  apply (metis hoare_triple_valid pre_closed tests_dual.sba_dual.reflexive)
  apply (meson hoare_triple_valid pre_compose)
  apply (smt hoare_triple_valid ite_import_mult sub_mult_closed)
  apply (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sba_dual.sub_sup_closed sub_mult_closed test_seq_def while_soundness_1)
  apply (smt hoare_triple_valid pre_iso tests_dual.transitive pre_closed)
  by (simp add: valid_rule_disj)

lemma nat_test_rule_while:
  "nat_test t s  -q  s  (n . t n*-p*-qxpSum t n*-q)  -q-px--p*-q"
  by (smt (verit, ccfv_threshold) hoare_triple_valid nat_test_def nat_test_pre pSum_test_nat sub_mult_closed)

lemma test_seq_rule_while:
  "test_seq t  -q  Sum t  t 0*-p*-qxaL*-q  (n>0 . t n*-p*-qxpSum t n*-q)  -q-px--p*-q"
  by (smt (verit, del_insts) hoare_triple_valid aL_test pSum_test sub_mult_closed test_seq_def while_soundness_1)

lemma rule_bot:
  "botx-p"
  by (metis hoare_triple_valid pre_closed tests_dual.top_double_complement tests_dual.top_greatest)

lemma rule_skip:
  "-p1-p"
  by (simp add: hoare_triple_valid pre_one_increasing)

lemma rule_example_4:
  assumes "test_seq t"
      and "Sum t = 1"
      and "t 0*-p1*-p3 = bot"
      and "-p1z1-p1*-p2"
      and "n>0 . t n*-p1*-p2*-p3z2pSum t n*-p1*-p2"
    shows "-p1z1*(-p3z2)-p2*--p3"
proof -
  have "t 0*-p3*(-p1*-p2) = bot"
    by (smt (verit, ccfv_threshold) assms(1,3) sub_assoc sub_comm sub_mult_closed test_seq_def tests_dual.sup_right_zero)
  hence 1: "t 0*-p3*(-p1*-p2)z2aL*(-p1*-p2)"
    by (metis aL_test sub_mult_closed rule_bot)
  have "n>0 . t n*-p3*(-p1*-p2)z2pSum t n*(-p1*-p2)"
    by (smt assms(1,5) lower_bound_left pSum_test rule_cons_pre sub_assoc sub_comm sub_mult_closed test_seq_def)
  hence "-p1*-p2-p3z2--p3*(-p1*-p2)"
    using 1 by (smt (verit, del_insts) assms(1,2) tests_dual.sub_bot_least rule_while sub_mult_closed)
  thus ?thesis
    by (smt assms(4) tests_dual.upper_bound_left rule_cons_post rule_seq sub_assoc sub_comm sub_mult_closed)
qed

end

class hoare_calculus_pc_2 = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes aL_one: "aL = 1"
begin

subclass hoare_calculus_sound_complete
  apply unfold_locales
  by (simp add: aL_one pre_below_one)

lemma while_soundness_pc:
  assumes "-p*-q  x«-q"
  shows "-q  -px«--p*-q"
proof -
  let ?t = "λx . 1"
  have 1: "test_seq ?t"
    by (simp add: test_seq_def)
  hence 2: "-q  Sum ?t"
    by (metis Sum_test Sum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least)
  have 3: "?t 0*-p*-q  x«aL*-q"
    using 1 by (simp add: assms aL_one)
  have "n>0 . ?t n*-p*-q  x«pSum ?t n*-q"
    using 1 by (metis assms pSum_test pSum_upper tests_dual.sba_dual.one_def tests_dual.antisymmetric tests_dual.sub_bot_least tests_dual.sup_left_unit)
  thus ?thesis
    using 1 2 3 aL_one while_soundness_0 by auto
qed

end

class hoare_calculus_pc = hoare_calculus_sound + hoare_calculus_pre_complete +
  assumes pre_one_one: "x«1 = 1"
begin

subclass hoare_calculus_pc_2
  apply unfold_locales
  by (simp add: aL_def pre_one_one)

end

class hoare_calculus_pc_valid = hoare_calculus_pc + hoare_calculus_valid
begin

lemma rule_while_pc:
  "-p*-qx-q  -q-px--p*-q"
  by (metis hoare_triple_valid sub_mult_closed while_soundness_pc)

lemma rule_alternation:
  "-px-q  -qy-p  -p-rx*y--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_alternation_context:
  "-pv-p  -pw-q  -qx-q  -qy-p  -pz-p  -p-rv*w*x*y*z--r*-p"
  by (meson rule_cons_pre_mult rule_seq rule_while_pc)

lemma rule_example_3:
  assumes "-p*-qx--p*-q"
      and "--p*-rx-p*-r"
      and "-p*-ry-p*-q"
      and "--p*-qz--p*-r"
    shows "-p*-q--p*-r-sx*(y-pz)--s*(-p*-q--p*-r)"
proof -
  have t1: "-p*-q--p*-rx--p*-q-p*-r"
    by (smt assms(1,2) rule_disj sub_mult_closed)
  have "-p*-ry-p*-q--p*-r"
    by (smt assms(3) rule_cons_post_plus sub_mult_closed)
  hence t2: "-p*(--p*-q-p*-r)y-p*-q--p*-r"
    by (smt (z3) tests_dual.sba_dual.less_eq_inf tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed tests_dual.sub_associative tests_dual.sub_sup_closed tests_dual.upper_bound_left tests_dual.wnf_lemma_3)
  have "--p*-qz-p*-q--p*-r"
    by (smt assms(4) tests_dual.inf_commutative rule_cons_post_plus sub_mult_closed)
  hence "--p*(--p*-q-p*-r)z-p*-q--p*-r"
    by (smt (z3) tests_dual.sba_dual.one_def tests_dual.sba_dual.sup_absorb tests_dual.sba_dual.sup_complement_intro tests_dual.sba_dual.sup_right_unit tests_dual.sub_sup_closed tests_dual.sup_complement_intro tests_dual.sup_left_dist_inf tests_dual.sup_right_unit tests_dual.top_double_complement)
  hence "--p*-q-p*-ry-pz-p*-q--p*-r"
    using t2 by (smt tests_dual.inf_closed rule_cond sub_mult_closed)
  hence "-s*(-p*-q--p*-r)x*(y-pz)-p*-q--p*-r"
    using t1 by (smt tests_dual.inf_closed rule_cons_pre_mult rule_seq sub_mult_closed)
  thus ?thesis
    by (smt tests_dual.inf_closed rule_while_pc sub_mult_closed)
qed

end

class hoare_calculus_tc = hoare_calculus + precondition_test_test + precondition_distr_mult +
  assumes while_bnd: "p  Test_expression  q  Pre_expression  x  While_program  px«q  Sum (λn . (p*x)^n«bot)"
begin

lemma
  assumes "p  Test_expression"
      and "q  Pre_expression"
      and "x  While_program"
    shows "px«q  tsum (-p) x (px«q) (-p(x«(px«q)*aL))"
proof -
  let ?w = "px«q"
  let ?s = "-p(x«?w*aL)"
  let ?t = "tseq (-p) x ?w ?s"
  let ?b = "λn . (p*x)^n«bot"
  have 2: "test_seq ?t"
    by (simp add: assms(2) pre_expression_test t_seq_test_seq)
  have 3: "test_seq ?b"
    using pre_closed test_seq_def tests_dual.sba_dual.complement_top by blast
  have 4: "?w = --?w"
    by (metis assms(2) pre_expression_test pre_closed)
  have "?w  Sum ?b"
    using assms while_bnd by blast
  hence 5: "?w = Sum ?b*?w"
    using 3 4 by (smt Sum_test leq_def sub_comm)
  have "n . ?b n*?w  ?t n"
  proof
    fix n
    show "?b n*?w  ?t n"
    proof (induct n)
      show "?b 0*?w  ?t 0"
        using 2 4 by (metis power.power_0 pre_one test_seq_def tests_dual.sup_left_zero tests_dual.top_double_complement tests_dual.top_greatest)
    next
      fix n
      assume 6: "?b n*?w  ?t n"
      have "-p  ?t (Suc n)"
        apply (unfold tseq_def power_succ_unfold_ext)
        by (smt assms(2) pre_expression_test t_seq_test pre_closed sub_mult_closed tfun_def tseq_def tests_dual.lower_bound_left)
      hence 7: "-p*?b (Suc n)*?w  ?t (Suc n)"
        using 2 3 4 by (smt tests_dual.upper_bound_left sub_mult_closed test_seq_def tests_dual.transitive)
      have 8: "p*?b (Suc n)*?w  x«?w*(?b n*?w)"
        by (smt assms(1,2) tests_dual.upper_bound_right tests_dual.sup_idempotent power_Suc pre_closed pre_distr_mult pre_expression_test pre_import_composition sub_assoc sub_comm sub_mult_closed test_expression_test while_pre_then tests_dual.top_double_complement)
      have 9: "...  x«?w*?t n"
        using 2 3 4 6 by (smt tests_dual.sub_sup_right_isotone pre_iso sub_mult_closed test_seq_def)
      have "...  ?t (Suc n)"
        using 2 4 by (smt power_succ_unfold_ext pre_closed sub_mult_closed test_seq_def tfun_def tseq_def tests_dual.lower_bound_right)
      hence "p*?b (Suc n)*?w  ?t (Suc n)"
        using 2 3 4 8 9 by (smt assms(1) pre_closed sub_mult_closed test_expression_test test_seq_def tests_dual.transitive)
      thus "?b (Suc n)*?w  ?t (Suc n)"
        using 2 3 4 7 by (smt assms(1) tests_dual.sup_less_eq_cases sub_assoc sub_mult_closed test_expression_test test_seq_def)
    qed
  qed
  hence "Sum ?b*?w  tsum (-p) x ?w ?s"
    using 3 4 by (smt assms(2) Sum_upper mult_right_dist_Sum pre_expression_test sub_mult_closed t_seq_test t_sum_test test_seq_def tests_dual.transitive tsum_def)
  thus ?thesis
    using 5 by auto
qed

end

class complete_pre = complete_tests + precondition + power
begin

definition bnd :: "'a  'a"
  where "bnd x  Sup { x^n«bot | n::nat . True }"

lemma bnd_test_set:
  "test_set { x^n«bot | n::nat . True }"
  by (smt (verit, del_insts) CollectD pre_closed test_set_def tests_dual.top_double_complement)

lemma bnd_test:
  "bnd x = --bnd x"
  using bnd_def bnd_test_set sup_test by auto

lemma bnd_upper:
  "x^m«bot  bnd x"
proof -
  have "x^m«bot  { x^m«bot | m::nat . True }"
    by auto
  thus ?thesis
    using bnd_def bnd_test_set sup_upper by auto
qed

lemma bnd_least:
  assumes "n . x^n«bot  -p"
    shows "bnd x  -p"
proof -
  have "y{ x^n«bot | n::nat . True } . y  -p"
    using assms by blast
  thus ?thesis
    using bnd_def bnd_test_set sup_least by auto
qed

lemma mult_right_dist_bnd:
  assumes "n . (x^n«bot)*-p  -q"
    shows "bnd x*-p  -q"
proof -
  have "Sup { y*-p | y . y  { x^n«bot | n::nat . True } }  -q"
    by (smt assms mem_Collect_eq tests_dual.complement_bot pre_closed sub_mult_closed sup_least test_set_def)
  thus ?thesis
    using bnd_test_set bnd_def mult_right_dist_sup by simp
qed

lemma tests_complete:
  "nat_test (λn . (-p*x)^n«bot) (bnd(-p*x))"
  using bnd_test bnd_upper mult_right_dist_bnd nat_test_def tests_dual.complement_bot pre_closed by blast

end

end

Theory Hoare_Modal

(* Title:      Hoare Calculus and Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Hoare Calculus and Modal Operators›

theory Hoare_Modal

imports Stone_Kleene_Relation_Algebras.Kleene_Algebras Complete_Domain Hoare Relative_Modal

begin

class box_precondition = relative_box_semiring + pre +
  assumes pre_def: "x«p = |x]p"
begin

text ‹Theorem 47›

subclass precondition
  apply unfold_locales
  apply (simp add: box_x_a pre_def)
  apply (simp add: box_left_mult pre_def)
  using box_def box_right_submult_a_a pre_def tests_dual.sba_dual.greatest_lower_bound apply fastforce
  by (simp add: box_1_a pre_def)

subclass precondition_test_test
  apply unfold_locales
  by (simp add: a_box_a_a pre_def)

subclass precondition_promote
  apply unfold_locales
  using a_mult_d box_def pre_def pre_test_test by auto

subclass precondition_test_box
  apply unfold_locales
  by (simp add: box_a_a d_def pre_def)

lemma pre_Z:
  "-p  x«-q  -p * x * --q  Z"
  by (simp add: box_demodalisation_2 pre_def)

lemma pre_left_dist_add:
  "xy«-q = (x«-q) * (y«-q)"
  by (simp add: box_left_dist_sup pre_def)

lemma pre_left_antitone:
  "x  y  y«-q  x«-q"
  by (simp add: box_antitone_isotone pre_def)

lemma pre_promote_neg:
  "(x«-q) * x * --q  Z"
  by (simp add: box_below_Z pre_def)

lemma pre_pc_Z:
  "x«1 = 1  x * bot  Z"
  by (simp add: a_strict box_x_1 pre_def)

(*
lemma pre_sub_promote: "(x«-q) * x ≤ (x«-q) * x * -q ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_promote: "(x«-q) * x ⊔ Z = (x«-q) * x * -q ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_mult_sub_promote: "(x*y«-q) * x ≤ (x*y«-q) * x * (y«-q) ⊔ Z" nitpick [expect=genuine,card=6] oops
lemma pre_mult_promote: "(x*y«-q) * x * (y«-q) ⊔ Z = (x*y«-q) * x ⊔ Z" nitpick [expect=genuine,card=6] oops
*)

end

class left_zero_box_precondition = box_precondition + relative_left_zero_antidomain_semiring
begin

lemma pre_sub_promote:
  "(x«-q) * x  (x«-q) * x * -q  Z"
  using case_split_right_sup pre_promote_neg by blast

lemma pre_promote:
  "(x«-q) * x  Z = (x«-q) * x * -q  Z"
  apply (rule sup_same_context)
  apply (simp add: pre_sub_promote)
  by (metis a_below_one le_supI1 mult_1_right mult_right_isotone)

lemma pre_mult_sub_promote:
  "(x*y«-q) * x  (x*y«-q) * x * (y«-q)  Z"
  by (metis pre_closed pre_seq pre_sub_promote)

lemma pre_mult_promote_sub:
  "(x*y«-q) * x * (y«-q)  (x*y«-q) * x"
  by (metis mult_right_isotone mult_1_right pre_below_one)

lemma pre_mult_promote:
  "(x*y«-q) * x * (y«-q)  Z = (x*y«-q) * x  Z"
  by (metis sup_ge1 sup_same_context order_trans pre_mult_sub_promote pre_mult_promote_sub)

end

class diamond_precondition = relative_box_semiring + pre +
  assumes pre_def: "x«p = |x>p"
begin

text ‹Theorem 47›

subclass precondition
  apply unfold_locales
  apply (simp add: d_def diamond_def pre_def)
  apply (simp add: diamond_left_mult pre_def)
  apply (metis a_antitone a_dist_sup box_antitone_isotone box_deMorgan_1 order.refl pre_def sup_right_divisibility)
  by (simp add: diamond_1_a pre_def)

subclass precondition_test_test
  apply unfold_locales
  by (metis diamond_a_a_same diamond_a_export diamond_associative diamond_right_mult pre_def)

subclass precondition_promote
  apply unfold_locales
  using d_def diamond_def pre_def pre_test_test tests_dual.sub_sup_closed by force

subclass precondition_test_diamond
  apply unfold_locales
  by (simp add: diamond_a_a pre_def)

lemma pre_left_dist_add:
  "xy«-q = (x«-q)  (y«-q)"
  by (simp add: diamond_left_dist_sup pre_def)

lemma pre_left_isotone:
  "x  y  x«-q  y«-q"
  by (metis diamond_left_isotone pre_def)

end

class box_while = box_precondition + bounded_left_conway_semiring + ite + while +
  assumes ite_def:   "xpy = p * x  -p * y"
  assumes while_def: "px = (p * x) * -p"
begin

subclass bounded_relative_antidomain_semiring ..

lemma Z_circ_left_zero:
  "Z * x = Z"
  using Z_left_zero_above_one circ_plus_one sup.absorb_iff2 by auto

subclass ifthenelse
  apply unfold_locales
  by (smt a_d_closed box_a_export box_left_dist_sup box_x_a tests_dual.case_duality d_def ite_def pre_def)

text ‹Theorem 48.1›

subclass whiledo
  apply unfold_locales
  apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
  using pre_mult_test_promote while_def by auto

lemma pre_while_1:
  "-p*(-px)«1 = -px«1"
proof -
  have "--p*(-p*(-px)«1) = --p*(-px«1)"
    by (metis mult_1_right pre_closed pre_seq pre_test_neg tests_dual.sba_dual.top_double_complement while_pre_else)
  thus ?thesis
    by (smt (z3) pre_closed pre_import tests_dual.sba_dual.top_double_complement tests_dual.sup_eq_cases)
qed

lemma aL_one_circ:
  "aL = a(1*bot)"
  by (metis aL_def box_left_mult box_x_a idempotent_bot_closed idempotent_one_closed pre_def tests_dual.sba_dual.one_def while_def tests_dual.one_def)

end

class diamond_while = diamond_precondition + bounded_left_conway_semiring + ite + while +
  assumes ite_def:   "xpy = p * x  -p * y"
  assumes while_def: "px = (p * x) * -p"
begin

subclass bounded_relative_antidomain_semiring ..

lemma Z_circ_left_zero:
  "Z * x = Z"
  by (simp add: Z_left_zero_above_one circ_reflexive)

subclass ifthenelse
  apply unfold_locales
  by (simp add: ite_def pre_export pre_left_dist_add)

text ‹Theorem 48.2›

subclass whiledo
  apply unfold_locales
  apply (smt circ_loop_fixpoint ite_def ite_pre mult_assoc mult_1_right pre_one pre_seq while_def)
  by (simp add: pre_mult_test_promote while_def)

lemma aL_one_circ:
  "aL = d(1*bot)"
  by (metis aL_def tests_dual.complement_bot diamond_x_1 mult_left_one pre_def while_def)

end

class box_while_program = box_while + atoms
begin

subclass while_program ..

end

class diamond_while_program = diamond_while + atoms
begin

subclass while_program ..

end

class box_hoare_calculus = box_while_program + complete_antidomain_semiring
begin

subclass hoare_calculus ..

end

class diamond_hoare_calculus = diamond_while_program + complete_antidomain_semiring
begin

subclass hoare_calculus ..

end

class box_hoare_sound = box_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
  assumes aL_circ: "aL * x  x"
begin

lemma aL_circ_ext:
  "|x]y  |aL * x]y"
  by (simp add: aL_circ box_left_antitone)

lemma box_star_induct:
  assumes "-p  |x](-p)"
    shows "-p  |x](-p)"
proof -
  have 1: "x*--p*top  Z  --p*top"
    by (metis assms Z_top sup_commute box_demodalisation_2 mult_assoc mult_left_isotone shunting_Z)
  have "x*(Z  --p*top)  x*--p*top  Z"
    using split_Z sup_monoid.add_commute mult_assoc by force
  also have "...  Z  --p*top"
    using 1 by simp
  finally have "x*(Z  --p*top)  --p  Z  --p*top"
    using le_supI2 sup.bounded_iff top_right_mult_increasing by auto
  thus ?thesis
    by (metis sup_commute box_demodalisation_2 mult_assoc shunting_Z star_left_induct)
qed

lemma box_circ_induct:
  "-p  |x](-p)  -p*aL  |x](-p)"
  by (smt aL_circ_ext aL_test box_left_mult box_star_induct order_trans tests_dual.inf_commutative pre_closed pre_def pre_test tests_dual.shunting_right)

lemma a_while_soundness:
  assumes "-p*-q  |x](-q)"
    shows "aL*-q  |(-p*x)*--p](-q)"
proof -
  have "|(-p*x)](-q)  |(-p*x)*--p](-q)"
    by (meson box_left_antitone circ_mult_upper_bound circ_reflexive order.refl order.trans tests_dual.sub_bot_least)
  thus ?thesis
    by (smt assms box_import_shunting box_circ_induct order_trans sub_comm aL_test)
qed

subclass hoare_calculus_sound
  apply unfold_locales
  by (simp add: a_while_soundness pre_def while_def)

end

class diamond_hoare_sound = diamond_hoare_calculus + left_kleene_conway_semiring +
  assumes aL_circ: "aL * x  x"
begin

lemma aL_circ_equal:
  "aL * x = aL * x"
  apply (rule order.antisym)
  using aL_circ aL_one_circ d_restrict_iff_1 apply force
  by (simp add: mult_right_isotone star_below_circ)

lemma aL_zero:
  "aL = bot"
  by (smt aL_circ_equal aL_one_circ d_export d_idempotent diamond_d_bot diamond_def mult_assoc mult_1_right star_one)

subclass hoare_calculus_sound
  apply unfold_locales
  using aL_zero by auto

end

class box_hoare_complete = box_hoare_calculus + left_kleene_conway_semiring +
  assumes box_circ_induct_2: "-p*|x](-q)  -q  |x](-p)  -qaL"
  assumes aL_zero_or_one: "aL = bot  aL = 1"
  assumes while_mult_left_dist_Prod: "x  While_program  descending_chain t  test_seq t  x*Prod t = Prod (λn . x*t n)"
begin

subclass hoare_calculus_complete
  apply unfold_locales
  apply (metis aL_zero_or_one bot_least order.eq_iff mult_1_right pre_closed tests_dual.sup_right_zero)
  subgoal
    apply (unfold pre_def box_def)
    by (metis a_ascending_chain a_dist_Prod a_dist_Sum descending_chain_left_mult while_mult_left_dist_Prod test_seq_def)
  by (smt box_circ_induct_2 tests_dual.double_negation tests_dual.greatest_lower_bound tests_dual.upper_bound_left mult_right_dist_sup pre_closed pre_def pre_import pre_seq pre_test sub_mult_closed while_def)

end

class diamond_hoare_complete = diamond_hoare_calculus + relative_domain_semiring_split + left_kleene_conway_semiring +
  assumes dL_circ: "-aL*x  x"
  assumes aL_zero_or_one: "aL = bot  aL = 1"
  assumes while_mult_left_dist_Sum: "x  While_program  ascending_chain t  test_seq t  x*Sum t = Sum (λn . x*t n)"
begin

lemma diamond_star_induct_var:
  assumes "|x>(d p)  d p"
    shows "|x>(d p)  d p"
proof -
  have "x * (d p * x  Z)  d p * x * x  Z * x  Z"
    by (metis assms sup_left_isotone d_mult_d diamond_def diamond_demodalisation_3 mult_assoc mult_left_isotone mult_right_dist_sup order_trans split_Z)
  also have "...  d p * x  Z"
    by (metis Z_mult_decreasing mult_right_isotone star.left_plus_below_circ sup.bounded_iff sup_ge1 sup_mono sup_monoid.add_commute mult_assoc)
  finally show ?thesis
    by (smt sup_commute le_sup_iff sup_ge2 d_mult_d diamond_def diamond_demodalisation_3 order_trans star.circ_back_loop_prefixpoint star_left_induct)
qed

lemma diamond_star_induct:
  "d q  |x>(d p)  d p  |x>(d q)  d p"
  by (metis le_sup_iff diamond_star_induct_var diamond_right_isotone order_trans)

lemma while_completeness_1:
  assumes "-p*(x«-q)  -q"
    shows "-px«-q  -qaL"
proof -
  have "--p*-q  |-p*x>(-q)  -q"
    using assms pre_def pre_export tests_dual.upper_bound_right by auto
  hence "|(-p*x)>(--p*-q)  -q"
    by (smt diamond_star_induct d_def sub_mult_closed tests_dual.double_negation)
  hence "|-aL*(-p*x)>(--p*-q)  -q"
    by (meson dL_circ diamond_isotone order.eq_iff order.trans)
  thus ?thesis
    by (smt aL_test diamond_a_export diamond_def mult_assoc tests_dual.inf_commutative pre_closed pre_def tests_dual.shunting while_def)
qed

subclass hoare_calculus_complete
  apply unfold_locales
  apply (metis aL_test aL_zero_or_one bot_least order.eq_iff pre_closed pre_test pre_test_one tests_dual.sup_right_zero)
  subgoal
    apply (unfold pre_def diamond_def)
    by (simp add: ascending_chain_left_mult d_dist_Sum while_mult_left_dist_Sum)
  by (simp add: while_completeness_1)

end

class box_hoare_valid = box_hoare_sound + box_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "pxq  p  |x]q"
begin

text ‹Theorem 49.2›

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

lemma rule_skip_valid:
  "-p1-p"
  by (simp add: rule_skip)

end

class diamond_hoare_valid = diamond_hoare_sound + diamond_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "pxq  p  |x>q"
begin

lemma circ_star_equal:
  "x = x"
  by (metis aL_zero order.antisym dL_circ mult_left_one one_def star_below_circ)

text ‹Theorem 49.1›

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

end

class diamond_hoare_sound_2 = diamond_hoare_calculus + left_kleene_conway_semiring +
  assumes diamond_circ_induct_2: "--p*-q  |x>(-q)   aL*-q  |x>(-p)"
begin

subclass hoare_calculus_sound
  apply unfold_locales
  by (smt a_export diamond_associative diamond_circ_induct_2 tests_dual.double_negation tests_dual.sup_complement_intro pre_def pre_import_equiv_mult sub_comm sub_mult_closed while_def)

end

class diamond_hoare_valid_2 = diamond_hoare_sound_2 + diamond_hoare_complete + hoare_triple +
  assumes hoare_triple_def: "pxq  p  |x>q"
begin

subclass hoare_calculus_valid
  apply unfold_locales
  by (simp add: hoare_triple_def pre_def)

end

end

Theory Pre_Post

(* Title:      Pre-Post Specifications
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Pre-Post Specifications›

theory Pre_Post

imports Preconditions

begin

class pre_post =
  fixes pre_post :: "'a  'a  'a" (infix "" 55)

class pre_post_spec_greatest = bounded_idempotent_left_semiring + precondition + pre_post +
  assumes pre_post_galois: "-p  x«-q  x  -p-q"
begin

text ‹Theorem 42.1›

lemma post_pre_left_antitone:
  "x  y  y«-q  x«-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "xy«-q  x«-q"
  by (simp add: post_pre_left_antitone)

text ‹Theorem 42.2›

lemma pre_post_left_antitone:
  "-p  -q  -q-r  -p-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p-q-r  -p-r"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_left_antitone)

lemma pre_post_left_sup_dist:
  "-p-r  -p*-q-r"
  by (metis tests_dual.sba_dual.sub_inf_def pre_post_left_sub_dist tests_dual.inf_absorb)

text ‹Theorem 42.5›

lemma pre_pre_post:
  "x  (x«-p)-p"
  by (metis order_refl pre_closed pre_post_galois)

text ‹Theorem 42.6›

lemma pre_post_pre:
  "-p  (-p-q)«-q"
  by (simp add: pre_post_galois)

text ‹Theorem 42.8›

lemma pre_post_zero_top:
  "bot-q = top"
  by (metis order.eq_iff pre_post_galois sup.cobounded2 sup_monoid.add_0_right top_greatest tests_dual.top_double_complement)

text ‹Theorem 42.7›

lemma pre_post_pre_one:
  "(1-q)«-q = 1"
  by (metis order.eq_iff pre_below_one tests_dual.sba_dual.top_double_complement pre_post_pre)

text ‹Theorem 42.3›

lemma pre_post_right_isotone:
  "-p  -q  -r-p  -r-q"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r-p  -r-p-q"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_right_isotone)

lemma pre_post_right_sup_dist:
  "-r-p*-q  -r-p"
  by (metis tests_dual.sub_sup_closed pre_post_right_isotone tests_dual.upper_bound_left)

text ‹Theorem 42.7›

lemma pre_post_reflexive:
  "1  -p-p"
  using pre_one_increasing pre_post_galois by auto

text ‹Theorem 42.9›

lemma pre_post_compose:
  "-q  -r  (-p-q)*(-r-s)  -p-s"
  using order_lesseq_imp pre_compose pre_post_galois by blast

text ‹Theorem 42.10›

lemma pre_post_compose_1:
  "(-p-q)*(-q-r)  -p-r"
  by (simp add: pre_post_compose)

text ‹Theorem 42.11›

lemma pre_post_compose_2:
  "(-p-p)*(-p-q) = -p-q"
  by (meson case_split_left order.eq_iff le_supI1 pre_post_compose_1 pre_post_reflexive)

text ‹Theorem 42.12›

lemma pre_post_compose_3:
  "(-p-q)*(-q-q) = -p-q"
  by (meson order.eq_iff order.trans mult_right_isotone mult_sub_right_one pre_post_compose_1 pre_post_reflexive)

text ‹Theorem 42.13›

lemma pre_post_compose_4:
  "(-p-p)*(-p-p) = -p-p"
  by (simp add: pre_post_compose_3)

text ‹Theorem 42.14›

lemma pre_post_one_one:
  "x«1 = 1  x  11"
  by (metis order.eq_iff one_def pre_below_one pre_post_galois)

text ‹Theorem 42.4›

lemma post_pre_left_dist_sup:
  "xy«-q = (x«-q)*(y«-q)"
  apply (rule order.antisym)
  apply (metis mult_isotone pre_closed sup_commute tests_dual.sup_idempotent pre_left_sub_dist)
  by (smt (z3) order.refl pre_closed pre_post_galois sup.boundedI tests_dual.sba_dual.greatest_lower_bound tests_dual.sub_sup_closed)

(*
lemma pre_post_right_dist_sup: "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" nitpick [expect=genuine,card=4] oops
*)

end

class pre_post_spec_greatest_2 = pre_post_spec_greatest + precondition_test_test
begin

subclass precondition_test_box
  apply unfold_locales
  by (smt (verit) sup_commute mult_1_right tests_dual.double_negation order.eq_iff mult_left_one mult_right_dist_sup one_def tests_dual.inf_complement tests_dual.inf_complement_intro pre_below_one pre_import pre_post_galois pre_test_test tests_dual.top_def bot_least)

lemma pre_post_seq_sub_associative:
  "(-p-q)*-r  -p-q*-r"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre sub_comm test_below_pre_test_mult tests_dual.sub_sup_closed)

lemma pre_post_right_import_mult:
  "(-p-q)*-r = (-p-q*-r)*-r"
  by (metis order.antisym mult_assoc tests_dual.sup_idempotent mult_left_isotone pre_post_right_sup_dist pre_post_seq_sub_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p-q)  --r-p-q"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed)

lemma pre_post_left_import_sup:
  "-r*(-p-q) = -r*(--r-p-q)"
  by (metis sup_commute order.antisym mult_assoc tests_dual.sup_idempotent mult_right_isotone pre_post_left_sub_dist seq_pre_post_sub_associative)

lemma pre_post_import_same:
  "-p*(-p-q) = -p*(1-q)"
  using pre_test pre_test_test_same pre_post_left_import_sup by auto

lemma pre_post_import_complement:
  "--p*(-p-q) = --p*top"
  by (metis tests_dual.sup_idempotent tests_dual.inf_cases tests_dual.inf_closed pre_post_left_import_sup pre_post_zero_top tests_dual.top_def tests_dual.top_double_complement)

lemma pre_post_export:
  "-p-q = (1-q)  --p*top"
proof (rule order.antisym)
  have 1: "-p*(-p-q)  (1-q)  --p*top"
    by (metis le_supI1 pre_test pre_test_test_same seq_pre_post_sub_associative)
  have "--p*(-p-q)  (1-q)  --p*top"
    by (simp add: pre_post_import_complement)
  thus "-p-q  (1-q)  --p*top"
    using 1 by (smt case_split_left eq_refl tests_dual.inf_complement)
next
  show "(1-q)  --p*top  -p-q"
    by (metis le_sup_iff tests_dual.double_negation tests_dual.sub_bot_least pre_neg_mult pre_post_galois pre_post_pre_one)
qed

lemma pre_post_left_dist_mult:
  "-p*-q-r = (-p-r)  (-q-r)"
proof -
  have "p q . -p*(-p*-q-r) = -p*(-q-r)"
    using sup_monoid.add_commute tests_dual.sba_dual.sub_inf_def pre_post_left_import_sup tests_dual.inf_complement_intro by auto
  hence 1: "(-p-q)*(-p*-q-r)  (-p-r)  (-q-r)"
    by (metis sup_commute le_sup_iff sup_ge2 mult_left_one mult_right_dist_sup tests_dual.inf_left_unit sub_comm)
  have "-(-p-q)*(-p*-q-r) = -(-p-q)*top"
    by (smt (z3) sup.left_commute sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed pre_post_import_complement pre_post_left_import_sup tests_dual.inf_absorb)
  hence "-(-p-q)*(-p*-q-r)  (-p-r)  (-q-r)"
    by (smt (z3) order.trans le_supI1 pre_post_left_sub_dist tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed seq_pre_post_sub_associative)
  thus ?thesis
    using 1 by (smt (z3) le_sup_iff order.antisym case_split_left order_refl tests_dual.inf_closed tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
qed

lemma pre_post_left_import_mult:
  "-r*(-p-q) = -r*(-r*-p-q)"
  by (metis sup_commute tests_dual.inf_complement_intro pre_post_left_import_sup sub_mult_closed)

lemma pre_post_right_import_sup:
  "(-p-q)*-r = (-p-q--r)*-r"
  by (smt (z3) sup_monoid.add_commute tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.inf_complement_intro tests_dual.sub_complement tests_dual.sub_inf_def pre_post_right_import_mult)

lemma pre_post_shunting:
  "x  -p*-q-r  -p*x  -q-r"
proof -
  have "--p*x  -p*-q-r"
    by (metis tests_dual.double_negation order_trans pre_neg_mult pre_post_galois pre_post_left_sup_dist)
  hence 1: "-p*x  -q-r  x  -p*-q-r"
    by (smt case_split_left eq_refl order_trans tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
  have "-p*(-p*-q-r)  -q-r"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least pre_post_left_import_mult)
  thus ?thesis
    using 1 mult_right_isotone order_lesseq_imp by blast
qed

(*
lemma pre_post_right_dist_sup: "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" oops
*)

end

class left_zero_pre_post_spec_greatest_2 = pre_post_spec_greatest_2 + bounded_idempotent_left_zero_semiring
begin

lemma pre_post_right_dist_sup:
  "-p-q-r = (-p-q)  (-p-r)"
proof -
  have 1: "(-p-q-r)*-q  (-p-q)  (-p-r)"
    by (metis le_supI1 pre_post_seq_sub_associative tests_dual.sba_dual.inf_absorb tests_dual.sba_dual.sub_sup_closed)
  have "(-p-q-r)*--q = (-p-r)*--q"
    by (simp add: pre_post_right_import_sup sup_commute)
  hence "(-p-q-r)*--q  (-p-q)  (-p-r)"
    by (metis sup_ge2 mult_left_sub_dist_sup_right mult_1_right order_trans tests_dual.inf_left_unit)
  thus ?thesis
    using 1 by (metis le_sup_iff order.antisym case_split_right tests_dual.sub_bot_least tests_dual.inf_commutative tests_dual.inf_complement pre_post_right_sub_dist)
qed

end

class havoc =
  fixes H :: "'a"

class idempotent_left_semiring_H = bounded_idempotent_left_semiring + havoc +
  assumes H_zero : "H * bot = bot"
  assumes H_split: "x  x * bot  H"
begin

lemma H_galois:
  "x * bot  y  x  y  H"
  apply (rule iffI)
  using H_split order_lesseq_imp sup_mono apply blast
  by (smt (verit, ccfv_threshold) H_zero mult_right_dist_sup sup.cobounded2 sup.orderE sup_assoc sup_bot_left sup_commute zero_right_mult_decreasing)

lemma H_greatest_finite:
  "x * bot = bot  x  H"
  by (metis H_galois le_iff_sup sup_bot_left sup_monoid.add_0_right)

lemma H_reflexive:
  "1  H"
  using H_greatest_finite mult_left_one by blast

lemma H_transitive:
  "H = H * H"
  by (metis H_greatest_finite H_reflexive H_zero preorder_idempotent mult_assoc)

lemma T_split_H:
  "top * bot  H = top"
  by (simp add: H_split order.antisym)

(*
lemma "H * (x ⊔ y) = H * x ⊔ H * y" nitpick [expect=genuine,card=6] oops
*)

end

class pre_post_spec_least = bounded_idempotent_left_semiring + precondition_test_test + precondition_promote + pre_post +
  assumes test_mult_right_distr_sup: "-p * (x  y) = -p * x  -p * y"
  assumes pre_post_galois: "-p  x«-q  -p-q  x"
begin

lemma shunting_top:
  "-p * x  y  x  y  --p * top"
proof
  assume "-p * x  y"
  thus "x  y  --p * top"
    by (smt (verit, ccfv_SIG) case_split_left eq_refl le_supI1 le_supI2 mult_right_isotone tests_dual.sba_dual.top_def top_greatest)
next
  assume "x  y  --p * top"
  hence "-p * x  -p * y"
    by (metis sup_bot_right mult_assoc tests_dual.sup_complement mult_left_zero mult_right_isotone test_mult_right_distr_sup)
  thus "-p * x  y"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least order_trans)
qed

lemma post_pre_left_isotone:
  "x  y  x«-q  y«-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "x«-q  xy«-q"
  by (simp add: post_pre_left_isotone)

lemma pre_post_left_isotone:
  "-p  -q  -p-r  -q-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p-r  -p-q-r"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_left_isotone)

lemma pre_post_left_sup_dist:
  "-p*-q-r  -p-r"
  by (metis tests_dual.upper_bound_left pre_post_left_isotone sub_mult_closed)

lemma pre_pre_post:
  "(x«-p)-p  x"
  by (metis order_refl pre_closed pre_post_galois)

lemma pre_post_pre:
  "-p  (-p-q)«-q"
  by (simp add: pre_post_galois)

lemma pre_post_zero_top:
  "bot-q = bot"
  using bot_least order.eq_iff pre_post_galois tests_dual.sba_dual.sub_bot_def by blast

lemma pre_post_pre_one:
  "(1-q)«-q = 1"
  by (metis order.eq_iff pre_below_one pre_post_pre tests_dual.sba_dual.top_double_complement)

lemma pre_post_right_antitone:
  "-p  -q  -r-q  -r-p"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r-p-q  -r-p"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_right_antitone)

lemma pre_post_right_sup_dist:
  "-r-p  -r-p*-q"
  by (metis tests_dual.upper_bound_left pre_post_right_antitone sub_mult_closed)

lemma pre_top:
  "top«-q = 1"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sba_dual.one_def top_greatest by blast

lemma pre_mult_top_increasing:
  "-p  -p*top«-q"
  using pre_import_equiv pre_top tests_dual.sub_bot_least by auto

lemma pre_post_below_mult_top:
  "-p-q  -p*top"
  using pre_import_equiv pre_post_galois by auto

lemma pre_post_import_complement:
  "--p*(-p-q) = bot"
proof -
  have "--p*(-p-q)  --p*(-p*top)"
    by (simp add: mult_right_isotone pre_post_below_mult_top)
  thus ?thesis
    by (metis mult_assoc mult_left_zero sub_comm tests_dual.top_def order.antisym bot_least)
qed

lemma pre_post_import_same:
  "-p*(-p-q) = -p-q"
proof -
  have "-p-q = -p*(-p-q)  --p*(-p-q)"
    by (metis mult_left_one mult_right_dist_sup tests_dual.inf_complement)
  thus ?thesis
    using pre_post_import_complement by auto
qed

lemma pre_post_export:
  "-p-q = -p*(1-q)"
proof (rule order.antisym)
  show "-p-q  -p*(1-q)"
    by (metis tests_dual.sub_bot_least pre_import_equiv pre_post_galois pre_post_pre_one)
next
  have 1: "-p  ((-p-q)  --p*top)«-q"
    by (simp add: pre_post_galois)
  have "--p  ((-p-q)  --p*top)«-q"
    by (simp add: le_supI2 pre_post_galois pre_post_below_mult_top)
  hence "-p  --p  ((-p-q)  --p*top)«-q"
    using 1 le_supI by blast
  hence "1  ((-p-q)  --p*top)«-q"
    by simp
  hence "1-q  (-p-q)  --p*top"
    using pre_post_galois tests_dual.sba_dual.one_def by blast
  thus "-p*(1-q)  -p-q"
    by (simp add: shunting_top)
qed

lemma pre_post_seq_associative:
  "-r*(-p-q) = -r*-p-q"
  by (metis pre_post_export tests_dual.sub_sup_closed mult_assoc)

lemma pre_post_left_import_mult:
  "-r*(-p-q) = -r*(-r*-p-q)"
  by (metis mult_assoc tests_dual.sup_idempotent pre_post_seq_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p-q)  --r-p-q"
  by (metis le_supI1 pre_post_left_sub_dist sup_commute shunting_top)

lemma pre_post_left_import_sup:
  "-r*(-p-q) = -r*(--r-p-q)"
  by (metis tests_dual.sba_dual.sub_sup_closed pre_post_seq_associative tests_dual.sup_complement_intro)

lemma pre_post_left_dist_sup:
  "-p-q-r = (-p-r)  (-q-r)"
  by (metis mult_right_dist_sup tests_dual.inf_closed pre_post_export)

lemma pre_post_reflexive:
  "-p-p  1"
  using pre_one_increasing pre_post_galois by auto

lemma pre_post_compose:
  "-q  -r  -p-s  (-p-q)*(-r-s)"
  by (meson pre_compose pre_post_galois pre_post_pre pre_post_right_antitone)

lemma pre_post_compose_1:
  "-p-r  (-p-q)*(-q-r)"
  by (simp add: pre_post_compose)

lemma pre_post_compose_2:
  "(-p-p)*(-p-q) = -p-q"
  using order.eq_iff mult_left_isotone pre_post_compose_1 pre_post_reflexive by fastforce

lemma pre_post_compose_3:
  "(-p-q)*(-q-q) = -p-q"
  by (metis order.antisym mult_right_isotone mult_1_right pre_post_compose_1 pre_post_reflexive)

lemma pre_post_compose_4:
  "(-p-p)*(-p-p) = -p-p"
  by (simp add: pre_post_compose_3)

lemma pre_post_one_one:
  "x«1 = 1  11  x"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sub_bot_def by force

lemma pre_one_right:
  "-p«1 = -p"
  by (metis order.antisym mult_1_right one_def tests_dual.inf_complement pre_left_sub_dist pre_mult_top_increasing pre_one pre_seq pre_test_promote pre_top)

lemma pre_pre_one:
  "x«-q = x*-q«1"
  by (metis one_def pre_one_right pre_seq)

subclass precondition_test_diamond
  apply unfold_locales
  using tests_dual.sba_dual.sub_inf_def pre_one_right pre_pre_one by auto

(*
lemma pre_post_shunting: "x ≤ -p*-q⊣-r ⟷ -p*x ≤ -q⊣-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q⊔-r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q⊔--r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q*-r)*-r" nitpick [expect=genuine,card=3] oops
lemma "(-p⊣-q)*-r = (-p⊣-q*--r)*-r" nitpick [expect=genuine,card=3] oops
lemma "-p⊣-q⊔-r = (-p⊣-q) ⊔ (-p⊣-r)" nitpick [expect=genuine,card=3] oops
lemma "-p⊣-q⊔-r = (-p⊣-q) * (-p⊣-r)" nitpick [expect=genuine,card=3] oops
lemma pre_post_right_dist_mult: "-p⊣-q*-r = (-p⊣-q) * (-p⊣-r)" oops
lemma pre_post_right_dist_mult: "-p⊣-q*-r = (-p⊣-q) ⊔ (-p⊣-r)" oops
lemma post_pre_left_dist_sup: "x⊔y«-q = (x«-q) ⊔ (y«-q)" oops
*)

end

class havoc_dual =
  fixes Hd :: "'a"

class idempotent_left_semiring_Hd = bounded_idempotent_left_semiring + havoc_dual +
  assumes Hd_total: "Hd * top = top"
  assumes Hd_least: "x * top = top  Hd  x"
begin

lemma Hd_least_total:
  "x * top = top  Hd  x"
  by (metis Hd_least Hd_total order.antisym mult_left_isotone top_greatest)

lemma Hd_reflexive:
  "Hd  1"
  by (simp add: Hd_least)

lemma Hd_transitive:
  "Hd = Hd * Hd"
  by (simp add: Hd_least Hd_total order.antisym coreflexive_transitive total_mult_closed)

end

class pre_post_spec_least_Hd = idempotent_left_semiring_Hd + pre_post_spec_least +
  assumes pre_one_mult_top: "(x«1)*top = x*top"
begin

lemma Hd_pre_one:
  "Hd«1 = 1"
  by (metis Hd_total pre_seq pre_top)

lemma pre_post_below_Hd:
  "11  Hd"
  using Hd_pre_one pre_post_one_one by auto

lemma Hd_pre_post:
  "Hd = 11"
  by (metis Hd_least Hd_pre_one Hd_total order.eq_iff pre_one_mult_top pre_post_one_one)

lemma top_left_zero:
  "top*x = top"
  by (metis mult_assoc mult_left_one mult_left_zero pre_closed pre_one_mult_top pre_seq pre_top)

lemma test_dual_test:
  "(-p--p*top)*-p = -p--p*top"
  by (simp add: top_left_zero mult_right_dist_sup mult_assoc)

lemma pre_zero_mult_top:
  "(x«bot)*top = x*bot"
  by (metis mult_assoc mult_left_zero one_def pre_one_mult_top pre_seq pre_bot)

lemma pre_one_mult_Hd:
  "(x«1)*Hd  x"
  by (metis Hd_pre_post one_def pre_closed pre_post_export pre_pre_post)

lemma Hd_mult_pre_one:
  "Hd*(x«1)  x"
proof -
  have 1: "-(x«1)*Hd*(x«1)  x"
    by (metis Hd_pre_post le_iff_sup mult_left_isotone pre_closed pre_one_right pre_post_export pre_pre_post sup_commute sup_monoid.add_0_right tests_dual.sba_dual.one_def tests_dual.top_def)
  have "(x«1)*Hd*(x«1)  x"
    by (metis mult_isotone mult_1_right one_def pre_below_one pre_one_mult_Hd)
  thus ?thesis
    using 1 by (metis case_split_left pre_closed reflexive_one_closed tests_dual.sba_dual.one_def tests_dual.sba_dual.top_def mult_assoc)
qed

lemma pre_post_one_def_1:
  assumes "1  x«-q"
    shows "Hd*(-q--q*top)  x"
proof -
  have "Hd*(-q--q*top)  x*-q*(-q--q*top)"
    by (metis assms Hd_pre_post order.antisym pre_below_one pre_post_one_one pre_pre_one mult_left_isotone)
  thus ?thesis
    by (metis mult_assoc tests_dual.sup_complement mult_left_sub_dist_sup_left mult_left_zero mult_1_right tests_dual.inf_complement test_mult_right_distr_sup order_trans)
qed

lemma pre_post_one_def:
  "1-q = Hd*(-q--q*top)"
proof (rule order.antisym)
  have "1  (11)*(-q--q)«1"
    by (metis pre_post_pre one_def mult_1_right tests_dual.inf_complement)
  also have "...  (11)*(-q--q*top)«-q"
    by (metis sup_right_isotone mult_right_isotone mult_1_right one_def post_pre_left_isotone pre_seq pre_test_promote test_dual_test top_right_mult_increasing)
  finally show "1-q  Hd*(-q--q*top)"
    using Hd_pre_post pre_post_galois tests_dual.sub_bot_def by blast
next
  show "Hd*(-q--q*top)  1-q"
    by (simp add: pre_post_pre_one pre_post_one_def_1)
qed

lemma pre_post_def:
  "-p-q = -p*Hd*(-q--q*top)"
  by (simp add: pre_post_export mult_assoc pre_post_one_def)

end

end

Theory Pre_Post_Modal

(* Title:      Pre-Post Specifications and Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Pre-Post Specifications and Modal Operators›

theory Pre_Post_Modal

imports Pre_Post Hoare_Modal

begin

class pre_post_spec_whiledo = pre_post_spec_greatest + whiledo
begin

lemma nat_test_pre_post:
  "nat_test t s  -q  s  (n . x  t n*-p*-q(pSum t n*-q))  -px  -q--p*-q"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

lemma nat_test_pre_post_2:
  "nat_test t s  -r  s  (n . x  t n*-p(pSum t n))  -px  -r1"
  by (smt (verit, ccfv_threshold) nat_test_def nat_test_pre_2 one_def pSum_test_nat pre_post_galois tests_dual.sub_sup_closed)

end

class pre_post_spec_hoare = pre_post_spec_whiledo + hoare_calculus_sound
begin

lemma pre_post_while:
  "x  -p*-q-q  -px  aL*-q-q"
  by (smt aL_test pre_post_galois sub_mult_closed while_soundness)

text ‹Theorem 43.1›

lemma while_soundness_3:
  "test_seq t  -q  Sum t  x  t 0*-p*-qaL*-q  (n>0 . x  t n*-p*-qpSum t n*-q)  -px  -q--p*-q"
  by (smt (verit, del_insts) aL_test pSum_test tests_dual.inf_closed pre_post_galois sub_mult_closed test_seq_def while_soundness_1)

text ‹Theorem 43.2›

lemma while_soundness_4:
  "test_seq t  -r  Sum t  (n . x  t n*-ppSum t n)  -px  -r1"
  by (smt one_def pSum_test pre_post_galois sub_mult_closed test_seq_def while_soundness_2)

end

class pre_post_spec_hoare_pc_2 = pre_post_spec_hoare + hoare_calculus_pc_2
begin

text ‹Theorem 43.3›

lemma pre_post_while_pc:
  "x  -p*-q-q  -px  -q--p*-q"
  by (metis pre_post_galois sub_mult_closed while_soundness_pc)

end

class pre_post_spec_hoare_pc = pre_post_spec_hoare + hoare_calculus_pc
begin

subclass pre_post_spec_hoare_pc_2 ..

lemma pre_post_one_one_top:
  "11 = top"
  using order.eq_iff pre_one_one pre_post_one_one by auto

end

class pre_post_spec_H = pre_post_spec_greatest + box_precondition + havoc +
  assumes H_zero_2: "H * bot = bot"
  assumes H_split_2: "x  x * -q * top  H * --q"
begin

subclass idempotent_left_semiring_H
  apply unfold_locales
  apply (rule H_zero_2)
  by (smt H_split_2 tests_dual.complement_bot mult_assoc mult_left_zero mult_1_right one_def)

lemma pre_post_def_iff:
  "-p * x * --q  Z  x  Z  --p * top  H * -q"
proof (rule iffI)
  assume "-p * x * --q  Z"
  hence "x * --q * top  Z  --p * top"
    by (smt (verit, ccfv_threshold) Z_left_zero_above_one case_split_left_sup mult_assoc mult_left_isotone mult_right_dist_sup mult_right_isotone top_greatest top_mult_top)
  thus "x  Z  --p * top  H * -q"
    by (metis sup_left_isotone order_trans H_split_2 tests_dual.double_negation)
next
  assume "x  Z  --p * top  H * -q"
  hence "-p * x * --q  -p * (Z * --q  --p * top * --q  H * -q * --q)"
    by (metis mult_left_isotone mult_right_dist_sup mult_right_isotone mult_assoc)
  thus "-p * x * --q  Z"
    by (metis H_zero_2 Z_mult_decreasing sup_commute sup_bot_left mult_assoc mult_right_dist_sup mult_right_isotone order_trans test_mult_left_dist_shunt test_mult_left_sub_dist_shunt tests_dual.top_def)
qed

lemma pre_post_def:
  "-p-q = Z  --p*top  H*-q"
  by (meson order.antisym order_refl pre_Z pre_post_galois pre_post_def_iff)

end

class pre_post_L = pre_post_spec_greatest + box_while + left_conway_semiring_L + left_kleene_conway_semiring +
  assumes circ_below_L_add_star: "x  L  x"
begin

text ‹a loop does not abort if its body does not abort›
text ‹this avoids abortion from all states* alternatively from states in -r if -r is an invariant›

lemma body_abort_loop:
  assumes "Z = L"
      and "x  -p1"
    shows "-px  11"
proof -
  have "-p * x * bot  L"
    by (metis assms pre_Z pre_post_galois tests_dual.sba_dual.one_def tests_dual.top_double_complement)
  hence "(-p * x) * bot  L"
    by (metis L_split le_iff_sup star_left_induct sup_bot_left)
  hence "(-p * x) * bot  L"
    by (smt L_left_zero L_split sup_commute circ_below_L_add_star le_iff_sup mult_right_dist_sup)
  thus ?thesis
    by (metis assms(1) a_restrict mult_isotone pre_pc_Z pre_post_compose_2 pre_post_one_one tests_dual.sba_dual.one_def while_def tests_dual.sup_right_zero)
qed

end

class pre_post_spec_Hd = pre_post_spec_least + diamond_precondition + idempotent_left_semiring_Hd +
  assumes d_mult_top: "d(x) * top = x * top"
begin

subclass pre_post_spec_least_Hd
  apply unfold_locales
  by (simp add: d_mult_top diamond_x_1 pre_def)

end

end

Theory Monotonic_Boolean_Transformers

(* Title:      Monotonic Boolean Transformers
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Monotonic Boolean Transformers›

theory Monotonic_Boolean_Transformers

imports MonoBoolTranAlgebra.Assertion_Algebra Base

begin

no_notation inf (infixl "" 70)
no_notation uminus ("- _" [81] 80)

context mbt_algebra
begin

lemma directed_left_mult:
  "directed Y  directed ((*) x ` Y)"
  apply (unfold directed_def)
  using le_comp by blast

lemma neg_assertion:
  "neg_assert x  assertion"
  by (metis bot_comp neg_assert_def wpt_def wpt_is_assertion mult_assoc)

lemma assertion_neg_assert:
  "x  assertion  x = neg_assert (neg_assert x)"
  by (metis neg_assertion uminus_uminus)

text ‹extend and dualise part of Viorel Preoteasa's theory›

definition "assumption  {x . 1  x  (x * bot)  (x ^ o) = x}"

definition "neg_assume (x::'a)  (x ^ o * top)  1"

lemma neg_assume_assert:
  "neg_assume x = (neg_assert (x ^ o)) ^ o"
  using dual_bot dual_comp dual_dual dual_inf dual_one neg_assert_def neg_assume_def by auto

lemma assert_iff_assume:
  "x  assertion  x ^ o  assumption"
  by (smt assertion_def assumption_def dual_bot dual_comp dual_dual dual_inf dual_le dual_one mem_Collect_eq)

lemma assertion_iff_assumption_subseteq:
  "X  assertion  dual ` X  assumption"
  using assert_iff_assume by blast

lemma assumption_iff_assertion_subseteq:
  "X  assumption  dual ` X  assertion"
  using assert_iff_assume by auto

lemma assumption_prop:
  "x  assumption  (x * bot)  1 = x"
  by (smt assert_iff_assume assertion_prop dual_comp dual_dual dual_neg_top dual_one dual_sup dual_top)

lemma neg_assumption:
  "neg_assume x  assumption"
  using assert_iff_assume neg_assertion neg_assume_assert by auto

lemma assumption_neg_assume:
  "x  assumption  x = neg_assume (neg_assume x)"
  by (smt assert_iff_assume assertion_neg_assert dual_dual neg_assume_assert)

lemma assumption_sup_comp_eq:
  "x  assumption  y  assumption  x  y = x * y"
  by (smt assert_iff_assume assertion_inf_comp_eq dual_comp dual_dual dual_sup)

lemma sup_uminus_assume[simp]:
  "x  assumption  x  neg_assume x = 1"
  by (smt assert_iff_assume dual_dual dual_one dual_sup neg_assume_assert sup_uminus)

lemma inf_uminus_assume[simp]:
  "x  assumption  x  neg_assume x = top"
  by (smt assert_iff_assume dual_dual dual_sup dual_top inf_uminus neg_assume_assert sup_bot_right)

lemma uminus_assumption[simp]:
  "x  assumption  neg_assume x  assumption"
  by (simp add: neg_assumption)

lemma uminus_uminus_assume[simp]:
  "x  assumption  neg_assume (neg_assume x) = x"
  by (simp add: assumption_neg_assume)

lemma sup_assumption[simp]:
  "x  assumption  y  assumption  x  y  assumption"
  by (smt assert_iff_assume dual_dual dual_sup inf_assertion)

lemma comp_assumption[simp]:
  "x  assumption  y  assumption  x * y  assumption"
  using assumption_sup_comp_eq sup_assumption by auto

lemma inf_assumption[simp]:
  "x  assumption  y  assumption  x  y  assumption"
  by (smt assert_iff_assume dual_dual dual_inf sup_assertion)

lemma assumption_comp_idempotent[simp]:
  "x  assumption  x * x = x"
  using assumption_sup_comp_eq by fastforce

lemma assumption_comp_idempotent_dual[simp]:
  "x  assumption  (x ^ o) * (x ^ o) = x ^ o"
  by (metis assumption_comp_idempotent dual_comp)

lemma top_assumption[simp]:
  "top  assumption"
  by (simp add: assumption_def)

lemma one_assumption[simp]:
  "1  assumption"
  by (simp add: assumption_def)

lemma assert_top:
  "neg_assert (neg_assert p) ^ o * bot = neg_assert p * top"
  by (smt bot_comp dual_comp dual_dual dual_top inf_comp inf_top_right mult.assoc mult.left_neutral neg_assert_def)

lemma assume_bot:
  "neg_assume (neg_assume p) ^ o * top = neg_assume p * bot"
  by (smt assert_top dual_bot dual_comp dual_dual neg_assume_assert)

definition "wpb x  (x * bot)  1"

lemma wpt_iff_wpb:
  "wpb x = wpt (x ^ o) ^ o"
  using dual_comp dual_dual dual_inf dual_one dual_top wpt_def wpb_def by auto

lemma wpb_is_assumption[simp]:
  "wpb x  assumption"
  using assert_iff_assume wpt_is_assertion wpt_iff_wpb by auto

lemma wpb_comp:
  "(wpb x) * x = x"
  by (smt dual_comp dual_dual dual_neg_top dual_sup wpt_comp wpt_iff_wpb)

lemma wpb_comp_2:
  "wpb (x * y) = wpb (x * (wpb y))"
  by (simp add: sup_comp mult_assoc wpb_def)

lemma wpb_assumption[simp]:
  "x  assumption  wpb x = x"
  by (simp add: assumption_prop wpb_def)

lemma wpb_choice:
  "wpb (x  y) = wpb x  wpb y"
  using sup_assoc sup_commute sup_comp wpb_def by auto

lemma wpb_dual_assumption:
  "x  assumption  wpb (x ^ o) = 1"
  by (smt assert_iff_assume dual_dual dual_one wpt_dual_assertion wpt_iff_wpb)

lemma wpb_mono:
  "x  y  wpb x  wpb y"
  by (metis le_iff_sup wpb_choice)

lemma assumption_disjunctive:
  "x  assumption  x  disjunctive"
  by (smt assert_iff_assume assertion_conjunctive dual_comp dual_conjunctive dual_dual)

lemma assumption_conjunctive:
  "x  assumption  x  conjunctive"
  by (smt assert_iff_assume assertion_disjunctive dual_comp dual_disjunctive dual_dual)

lemma wpb_le_assumption:
  "x  assumption  x * y = y  x  wpb y"
  by (metis assumption_prop bot_least le_comp sup_commute sup_right_isotone mult_assoc wpb_def)

definition dual_omega :: "'a  'a" ("(_ ^ )" [81] 80)
  where "(x ^ )  (((x ^ o) ^ ω) ^ o)"

lemma dual_omega_fix:
  "x^ = (x * (x^))  1"
  by (smt dual_comp dual_dual dual_omega_def dual_one dual_sup omega_fix)

lemma dual_omega_comp_fix:
  "x^ * y = (x * (x^) * y)  y"
  by (metis dual_omega_fix mult_1_left sup_comp)

lemma dual_omega_greatest:
  "z  (x * z)  y  z  (x^) * y"
  by (smt dual_comp dual_dual dual_le dual_neg_top dual_omega_def dual_sup omega_least)

end

context post_mbt_algebra
begin

lemma post_antitone:
  assumes "x  y"
    shows "post y  post x"
proof -
  have "post y  post x * y * top  post y"
    by (metis assms inf_top_left post_1 inf_mono le_comp_left_right order_refl)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_assumption_below_one:
  "q  assumption  post q  post 1"
  by (simp add: assumption_def post_antitone)

lemma post_assumption_above_one:
  "q  assumption  post 1  post (q ^ o)"
  by (metis dual_le dual_one post_antitone sup.commute sup_ge1 wpb_assumption wpb_def)

lemma post_assumption_below_dual:
  "q  assumption  post q  post (q ^ o)"
  using order_trans post_assumption_above_one post_assumption_below_one by blast

lemma assumption_assertion_absorb:
  "q  assumption  q * (q ^ o) = q"
  by (smt CollectE assumption_def assumption_prop bot_comp mult.left_neutral mult_assoc sup_comp)

lemma post_dual_below_post_one:
  assumes "q  assumption"
  shows "post (q ^ o)  post 1 * q"
proof -
  have "post (q ^ o)  post 1 * q * (q ^ o) * top  post (q ^ o)"
    by (metis assms assumption_assertion_absorb gt_one_comp inf_le1 inf_top_left mult_assoc order_refl post_1 sup_uminus_assume top_unique)
  thus ?thesis
    using order_lesseq_imp post_2 by blast
qed

lemma post_below_post_one:
  "q  assumption  post q  post 1 * q"
  using order.trans post_assumption_below_dual post_dual_below_post_one by blast

end

context complete_mbt_algebra
begin

lemma Inf_assumption[simp]:
  "X  assumption  Inf X  assumption"
  by (metis Sup_assertion assert_iff_assume assumption_iff_assertion_subseteq dual_Inf dual_dual)

definition "continuous x  (Y . directed Y  x * (SUP yY . y) = (SUP yY . x * y))"

definition "Continuous  { x . continuous x }"

lemma continuous_Continuous:
  "continuous x  x  Continuous"
  by (simp add: Continuous_def)

text ‹Theorem 53.1›

lemma one_continuous:
  "1  Continuous"
  by (simp add: Continuous_def continuous_def image_def)

lemma continuous_dist_ascending_chain:
  assumes "x  Continuous"
      and "ascending_chain f"
    shows "x * (SUP n::nat . f n) = (SUP n::nat . x * f n)"
proof -
  have "directed (range f)"
    by (simp add: assms(2) ascending_chain_directed)
  hence "x * (SUP n::nat . f n) = (SUP yrange f . x * y)"
    using assms(1) continuous_Continuous continuous_def by auto
  thus ?thesis
    by (simp add: range_composition)
qed

text ‹Theorem 53.1›

lemma assertion_continuous:
  assumes "x  assertion"
    shows "x  Continuous"
proof -
  have 1: "x = (x * top)  1"
    using assms assertion_prop by auto
  have "Y . directed Y  x * (SUP yY . y) = (SUP yY . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y" (* assumption not used *)
    have "x * (SUP yY . y) = (x * top)  (SUP yY . y)"
      using 1 by (smt inf_comp mult.assoc mult.left_neutral top_comp)
    also have "... = (SUP yY . (x * top)  y)"
      by (simp add: inf_Sup)
    finally show "x * (SUP yY . y) = (SUP yY . x * y)"
      using 1 by (smt inf_comp mult.left_neutral mult.assoc top_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text ‹Theorem 53.1›

lemma assumption_continuous:
  assumes "x  assumption"
    shows "x  Continuous"
proof -
  have 1: "x = (x * bot)  1"
    by (simp add: assms assumption_prop)
  have "Y . directed Y  x * (SUP yY . y) = (SUP yY . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume 2: "directed Y"
    have "x * (SUP yY . y) = (x * bot)  (SUP yY . y)"
      using 1 by (smt sup_comp mult.assoc mult.left_neutral bot_comp)
    also have "... = (SUP yY . (x * bot)  y)"
      using 2 by (smt (verit, ccfv_threshold) sup_SUP SUP_cong directed_def)
    finally show "x * (SUP yY . y) = (SUP yY . x * y)"
      using 1 by (metis sup_comp mult.left_neutral mult.assoc bot_comp SUP_cong)
  qed
  thus ?thesis
    by (simp add: continuous_def Continuous_def)
qed

text ‹Theorem 53.1›

lemma mult_continuous:
  assumes "x  Continuous"
      and "y  Continuous"
    shows "x * y  Continuous"
proof -
  have "Y. directed Y  x * y * (SUP yY . y) = (SUP zY . x * y * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * y * (SUP wY . w) = (SUP zY . x * (y * z))"
      by (metis assms continuous_Continuous continuous_def directed_left_mult image_ident image_image mult_assoc)
    thus "x * y * (SUP yY . y) = (SUP zY . x * y * z)"
      using mult_assoc by auto
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma sup_continuous:
  "x  Continuous  y  Continuous  x  y  Continuous"
  by (smt SUP_cong SUP_sup_distrib continuous_Continuous continuous_def sup_comp)

text ‹Theorem 53.1›

lemma inf_continuous:
  assumes "x  Continuous"
      and "y  Continuous"
    shows "x  y  Continuous"
proof -
  have "Y. directed Y  (x  y) * (SUP yY . y) = (SUP zY . (x  y) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    have 2: "(SUP wY . SUP zY . (x * w)  (y * z))  (SUP zY . (x * z)  (y * z))"
    proof (intro SUP_least)
      fix w z
      assume "w  Y" and "z  Y"
      from this obtain v where 3: "vY  w  v  z  v"
        using 1 by (meson directed_def)
      hence "x * w  (y * z)  (x * v)  (y * v)"
        by (meson inf.sup_mono le_comp)
      thus "x * w  (y * z)  (SUP zY . (x * z)  (y * z))"
        using 3 by (meson SUP_upper2)
    qed
    have "(SUP zY . (x * z)  (y * z))  (SUP wY . SUP zY . (x * w)  (y * z))"
      apply (rule SUP_least)
      by (meson SUP_upper SUP_upper2)
    hence "(SUP wY . SUP zY . (x * w)  (y * z)) = (SUP zY . (x  y) * z)"
      using 2 order.antisym inf_comp by auto
    thus "(x  y) * (SUP yY . y) = (SUP zY . (x  y) * z)"
      using 1 by (metis assms inf_comp continuous_Continuous continuous_def SUP_inf_distrib2)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma dual_star_continuous:
  assumes "x  Continuous"
    shows "x ^   Continuous"
proof -
  have "Y. directed Y  (x ^ ) * (SUP yY . y) = (SUP zY . (x ^ ) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "directed ((*) (x ^ ) ` Y)"
      by (simp add: directed_left_mult)
    hence "x * (SUP yY . (x ^ ) * y) = (SUP yY . x * ((x ^ ) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    also have "... = (SUP yY . x * (x ^ ) * y)"
      using mult_assoc by auto
    also have "...  (SUP yY . (x ^ ) * y)"
      apply (rule SUP_least)
      by (simp add: SUP_upper2 dual_star_comp_fix)
    finally have "x * (SUP yY . (x ^ ) * y)  (SUP yY . y)  (SUP yY . (x ^ ) * y)"
      apply (rule sup_least)
      by (metis SUP_mono' dual_star_comp_fix sup.cobounded1 sup_commute)
    thus "(x ^ ) * (SUP yY . y) = (SUP zY . (x ^ ) * z)"
      by (meson SUP_least SUP_upper order.antisym dual_star_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

text ‹Theorem 53.1›

lemma omega_continuous:
  assumes "x  Continuous"
    shows "x ^ ω  Continuous"
proof -
  have "Y. directed Y  (x ^ ω) * (SUP yY . y) = (SUP zY . (x ^ ω) * z)"
  proof (rule allI, rule impI)
    fix Y
    assume 1: "directed Y"
    hence "directed ((*) (x ^ ω) ` Y)"
      using directed_left_mult by auto
    hence "x * (SUP yY . (x ^ ω) * y) = (SUP yY . x * ((x ^ ω) * y))"
      by (metis assms continuous_Continuous continuous_def image_ident image_image)
    hence 2: "x * (SUP yY . (x ^ ω) * y) = (SUP yY . x * (x ^ ω) * y)"
      by (simp add: mult_assoc)
    have "(SUP yY . x * (x ^ ω) * y)  (SUP yY . y) = (SUP wY . SUP zY . (x * (x ^ ω) * w)  z)"
      using SUP_inf_distrib2 by blast
    hence "x * (SUP yY . (x ^ ω) * y)  (SUP yY . y) = (SUP wY . SUP zY . (x * (x ^ ω) * w)  z)"
      using 2 by auto
    also have "...  (SUP yY . (x ^ ω) * y)"
    proof (intro SUP_least)
      fix w z
      assume "w  Y" and "z  Y"
      from this obtain v where 3: "vY  w  v  z  v"
        using 1 by (meson directed_def)
      hence "x * x ^ ω * w  z  x ^ ω * v"
        using inf.sup_mono le_comp omega_comp_fix by auto
      thus "x * x ^ ω * w  z  (SUP yY . (x ^ ω) * y)"
        using 3 by (meson SUP_upper2)
    qed
    finally show "(x ^ ω) * (SUP yY . y) = (SUP zY . (x ^ ω) * z)"
      by (meson SUP_least SUP_upper order.antisym omega_least le_comp)
  qed
  thus ?thesis
    using Continuous_def continuous_def by blast
qed

definition "co_continuous x  (Y . co_directed Y  x * (INF yY . y) = (INF yY . x * y))"

definition "Co_continuous  { x . co_continuous x }"

lemma directed_dual:
  "directed X  co_directed (dual ` X)"
  by (simp add: directed_def co_directed_def dual_le[THEN sym])

lemma dual_dual_image:
  "dual ` dual ` X = X"
  by (simp add: image_comp)

lemma continuous_dual:
  "continuous x  co_continuous (x ^ o)"
proof (unfold continuous_def co_continuous_def, rule iffI)
  assume 1: "Y. directed Y  x * (SUP yY . y) = (SUP yY . x * y)"
  show "Y. co_directed Y  x ^ o * (INF yY . y) = (INF yY . x ^ o * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "co_directed Y"
    hence "x ^ o * (INF yY . y) = (INF y(dual ` Y) . (x * y) ^ o)"
      using 1 by (metis dual_dual_image dual_SUP image_ident image_image dual_comp directed_dual)
    also have "... = (INF y(dual ` Y) . x ^ o * y ^ o)"
      by (meson dual_comp)
    also have "... = (INF yY . x ^ o * y)"
      by (simp add: image_image)
    finally show "x ^ o * (INF yY . y) = (INF yY . x ^ o * y)"
      .
 qed
next
  assume 2: "Y. co_directed Y  x ^ o * (INF yY . y) = (INF yY . x ^ o * y)"
  show "Y. directed Y  x * (SUP yY . y) = (SUP yY . x * y)"
  proof (rule allI, rule impI)
    fix Y
    assume "directed Y"
    hence "x * (SUP yY . y) = (SUP y(dual ` Y) . (x ^ o * y) ^ o)"
      using 2 by (metis directed_dual dual_dual_image image_ident image_image dual_SUP dual_comp dual_dual)
    also have "... = (SUP y(dual ` Y) . x * y ^ o)"
      using dual_comp dual_dual by auto
    also have "... = (SUP yY . x * y)"
      by (simp add: image_image)
    finally show "x * (SUP yY . y) = (SUP yY . x * y)"
      .
 qed
qed

lemma co_continuous_Co_continuous:
  "co_continuous x  x  Co_continuous"
  by (simp add: Co_continuous_def)

text ‹Theorem 53.1 and Theorem 53.2›

lemma Continuous_dual:
  "x  Continuous  x ^ o  Co_continuous"
  by (simp add: Co_continuous_def Continuous_def continuous_dual)

text ‹Theorem 53.2›

lemma one_co_continuous:
  "1  Co_continuous"
  using Continuous_dual one_continuous by auto

lemma ascending_chain_dual:
  "ascending_chain f  descending_chain (dual o f)"
  using ascending_chain_def descending_chain_def dual_le by auto

lemma co_continuous_dist_descending_chain:
  assumes "x  Co_continuous"
      and "descending_chain f"
    shows "x * (INF n::nat . f n) = (INF n::nat . x * f n)"
proof -
  have "x ^ o * (SUP n::nat . (dual o f) n) = (SUP n::nat . x ^ o * (dual o f) n)"
    by (smt assms Continuous_dual SUP_cong ascending_chain_dual continuous_dist_ascending_chain descending_chain_def dual_dual o_def)
  thus ?thesis
    by (smt INF_cong dual_SUP dual_comp dual_dual o_def)
qed

text ‹Theorem 53.2›

lemma assertion_co_continuous:
  "x  assertion  x  Co_continuous"
  by (smt Continuous_dual assert_iff_assume assumption_continuous dual_dual)

text ‹Theorem 53.2›

lemma assumption_co_continuous:
  "x  assumption  x  Co_continuous"
  by (smt Continuous_dual assert_iff_assume assertion_continuous dual_dual)

text ‹Theorem 53.2›

lemma mult_co_continuous:
  "x  Co_continuous  y  Co_continuous  x * y  Co_continuous"
  by (smt Continuous_dual dual_comp dual_dual mult_continuous)

text ‹Theorem 53.2›

lemma sup_co_continuous:
  "x  Co_continuous  y  Co_continuous  x  y  Co_continuous"
  by (smt Continuous_dual dual_sup dual_dual inf_continuous)

text ‹Theorem 53.2›

lemma inf_co_continuous:
  "x  Co_continuous  y  Co_continuous  x  y  Co_continuous"
  by (smt Continuous_dual dual_inf dual_dual sup_continuous)

text ‹Theorem 53.2›

lemma dual_omega_co_continuous:
  "x  Co_continuous  x ^   Co_continuous"
  by (smt Continuous_dual dual_omega_def dual_dual omega_continuous)

text ‹Theorem 53.2›

lemma star_co_continuous:
  "x  Co_continuous  x ^ *  Co_continuous"
  by (smt Continuous_dual dual_star_def dual_dual dual_star_continuous)

lemma dual_omega_iterate:
  assumes "y  Co_continuous"
    shows "y ^  * z = (INF n::nat . ((λx . y * x  z) ^ n) top)"
proof (rule order.antisym)
  show "y ^  * z  (INF n::nat . ((λx . y * x  z) ^ n) top)"
  proof (rule INF_greatest)
    fix n
    show "y ^  * z  ((λx. y * x  z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt dual_omega_comp_fix le_comp mult_assoc order_refl sup_mono power_succ_unfold_ext)
  qed
next
  have 1: "descending_chain (λn . ((λx. y * x  z) ^ n) top)"
  proof (unfold descending_chain_def, rule allI)
    fix n
    show "((λx. y * x  z) ^ Suc n) top  ((λx. y * x  z) ^ n) top"
      apply (induct n)
      apply (metis power_zero_id id_def top_greatest)
      by (smt power_succ_unfold_ext sup_mono order_refl le_comp)
  qed
  have "(INF n. ((λx. y * x  z) ^ n) top)  (INF n. ((λx. y * x  z) ^ Suc n) top)"
    apply (rule INF_greatest)
    apply (unfold power_succ_unfold_ext)
    by (smt power_succ_unfold_ext INF_lower UNIV_I)
  thus "(INF n. ((λx. y * x  z) ^ n) top)  y ^  * z"
    using 1 by (smt assms INF_cong co_continuous_dist_descending_chain power_succ_unfold_ext sup_INF sup_commute dual_omega_greatest)
qed

lemma dual_omega_iterate_one:
  "y  Co_continuous  y ^  = (INF n::nat . ((λx . y * x  1) ^ n) top)"
  by (metis dual_omega_iterate mult.right_neutral)

subclass ccpo
  apply unfold_locales
  apply (simp add: Sup_upper)
  using Sup_least by auto

end

class post_mbt_algebra_ext = post_mbt_algebra +
  assumes post_sub_fusion: "post 1 * neg_assume q  post (neg_assume q ^ o)"
begin

lemma post_fusion:
  "post (neg_assume q ^ o) = post 1 * neg_assume q"
  using order.antisym neg_assumption post_dual_below_post_one post_sub_fusion by auto

lemma post_dual_post_one:
  "q  assumption  post 1 * q  post (q ^ o)"
  by (metis assumption_neg_assume post_sub_fusion)

end

instance MonoTran :: (complete_boolean_algebra) post_mbt_algebra_ext
proof
  fix q :: "'a MonoTran"
  show "post 1 * neg_assume q  post (neg_assume q ^ o)"
  proof (unfold neg_assume_def, transfer)
    fix f :: "'a  'a"
    assume "mono f"
    have "x. top  -f bot  x  ¬ f bot  x  top  bot"
      by (metis (no_types, lifting) double_compl inf.sup_bot_left inf_compl_bot sup.order_iff sup_bot_left sup_commute sup_inf_distrib1 top.extremum_uniqueI)
    hence "post_fun top  (dual_fun f  top)  id  post_fun (f bot)"
      by (simp add: dual_fun_def le_fun_def post_fun_def)
    thus "post_fun (id top)  (dual_fun f  top)  id  post_fun (dual_fun ((dual_fun f  top)  id) top)"
      by simp
  qed
qed

class complete_mbt_algebra_ext = complete_mbt_algebra + post_mbt_algebra_ext

instance MonoTran :: (complete_boolean_algebra) complete_mbt_algebra_ext ..

end

Theory Monotonic_Boolean_Transformers_Instances

(* Title:      Instances of Monotonic Boolean Transformers
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Instances of Monotonic Boolean Transformers›

theory Monotonic_Boolean_Transformers_Instances

imports Monotonic_Boolean_Transformers Pre_Post_Modal General_Refinement_Algebras

begin

sublocale mbt_algebra < mbta: bounded_idempotent_left_semiring
  apply unfold_locales
  apply (simp add: le_comp)
  apply (simp add: sup_comp)
  apply simp
  apply simp
  apply simp
  apply simp
  by (simp add: mult_assoc)

sublocale mbt_algebra < mbta_dual: bounded_idempotent_left_semiring where less = greater and less_eq = greater_eq and sup = inf and bot = top and top = bot
  apply unfold_locales
  using inf.bounded_iff inf_le1 inf_le2 mbta.mult_right_isotone apply simp
  using inf_comp apply blast
  apply simp
  apply simp
  apply simp
  apply simp
  by (simp add: mult_assoc)

sublocale mbt_algebra < mbta: bounded_general_refinement_algebra where star = dual_star and Omega = dual_omega
  apply unfold_locales
  using dual_star_fix sup_commute apply force
  apply (simp add: dual_star_least)
  using dual_omega_fix sup_commute apply force
  by (simp add: dual_omega_greatest sup_commute)

sublocale mbt_algebra < mbta_dual: bounded_general_refinement_algebra where less = greater and less_eq = greater_eq and sup = inf and bot = top and Omega = omega and top = bot
  apply unfold_locales
  using order.eq_iff star_fix apply simp
  using star_greatest apply simp
  using inf_commute omega_fix apply fastforce
  by (simp add: inf.sup_monoid.add_commute omega_least)

text ‹Theorem 50.9(b)›

sublocale mbt_algebra < mbta: left_conway_semiring_L where circ = dual_star and L = bot
  apply unfold_locales
  apply (simp add: mbta.star_one)
  by simp

text ‹Theorem 50.8(a)›

sublocale mbt_algebra < mbta_dual: left_conway_semiring_L where circ = omega and less = greater and less_eq = greater_eq and sup = inf and bot = top and L = bot
  apply unfold_locales
  apply simp
  by simp

text ‹Theorem 50.8(b)›

sublocale mbt_algebra < mbta_fix: left_conway_semiring_L where circ = dual_omega and L = top
  apply unfold_locales
  apply (simp add: mbta.Omega_one)
  by simp

text ‹Theorem 50.9(a)›

sublocale mbt_algebra < mbta_fix_dual: left_conway_semiring_L where circ = star and less = greater and less_eq = greater_eq and sup = inf and bot = top and L = top
  apply unfold_locales
  apply (simp add: mbta_dual.star_one)
  by simp

sublocale mbt_algebra < mbta: left_kleene_conway_semiring where circ = dual_star and star = dual_star ..

sublocale mbt_algebra < mbta_dual: left_kleene_conway_semiring where circ = omega and less = greater and less_eq = greater_eq and sup = inf and bot = top ..

sublocale mbt_algebra < mbta_fix: left_kleene_conway_semiring where circ = dual_omega and star = dual_star ..

sublocale mbt_algebra < mbta_fix_dual: left_kleene_conway_semiring where circ = star and less = greater and less_eq = greater_eq and sup = inf and bot = top ..

sublocale mbt_algebra < mbta: tests where uminus = neg_assert
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis neg_assertion assertion_inf_comp_eq inf_commute)
  subgoal for x y
  proof -
    have "(x ^ o * bot  y * top)  ((x ^ o * bot  y ^ o * bot)  1) = x ^ o * bot  1"
      by (metis inf_assoc dual_neg sup_bot_right sup_inf_distrib1)
    thus ?thesis
      by (simp add: dual_inf dual_comp inf_comp sup_comp neg_assert_def)
  qed
  apply (simp add: neg_assertion)
  using assertion_inf_comp_eq inf_uminus neg_assertion apply force
  apply (simp add: neg_assert_def)
  apply (simp add: dual_inf dual_comp sup_comp neg_assert_def inf_sup_distrib2)
  apply (simp add: assertion_inf_comp_eq inf.absorb_iff1 neg_assertion)
  using inf.less_le_not_le by blast

sublocale mbt_algebra < mbta_dual: tests where less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis neg_assumption assumption_sup_comp_eq sup_commute)
  subgoal for x y
  proof -
    have "(x ^ o * top  y * bot)  ((x ^ o * top  y ^ o * top)  1) = x ^ o * top  1"
      by (metis dual_dual dual_neg_top inf_sup_distrib1 inf_top_right sup_assoc)
    thus ?thesis
      by (simp add: dual_comp dual_sup inf_comp sup_comp neg_assume_def)
  qed
  using assumption_neg_assume comp_assumption neg_assumption apply blast
  using assumption_sup_comp_eq inf_uminus_assume neg_assumption apply fastforce
  apply (simp add: neg_assume_def)
  apply (simp add: dual_inf dual_comp dual_sup inf_comp sup_comp neg_assume_def sup_inf_distrib2)
  apply (simp add: assumption_sup_comp_eq neg_assumption sup.absorb_iff1)
  using inf.less_le_not_le by auto

text ‹Theorem 51.2›

sublocale mbt_algebra < mbta: bounded_relative_antidomain_semiring where d = "λx . (x * top)  1" and uminus = neg_assert and Z = bot
  apply unfold_locales
  subgoal for x
  proof -
    have "x ^ o * bot  x  bot"
      by (metis dual_neg eq_refl inf.commute inf_mono mbta.top_right_mult_increasing)
    thus ?thesis
      by (simp add: neg_assert_def inf_comp)
  qed
  apply (simp add: dual_comp dual_inf neg_assert_def sup_comp mult_assoc)
  apply simp
  apply simp
  apply (simp add: dual_inf dual_comp sup_comp neg_assert_def inf_sup_distrib2)
  apply (simp add: dual_sup inf_comp neg_assert_def inf.assoc)
  by (simp add: dual_inf dual_comp sup_comp neg_assert_def)

text ‹Theorem 51.1›

sublocale mbt_algebra < mbta_dual: bounded_relative_antidomain_semiring where d = "λx . (x * bot)  1" and less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and top = bot and Z = top
  apply unfold_locales
  subgoal for x
  proof -
    have "top  x ^ o * top  x"
      by (metis dual_dual dual_neg_top mbta_dual.top_right_mult_increasing sup_commute sup_left_isotone)
    thus ?thesis
      by (simp add: sup_comp neg_assume_def)
  qed
  using assume_bot dual_comp neg_assume_def sup_comp mult_assoc apply simp
  apply simp
  apply simp
  apply (simp add: dual_inf dual_comp dual_sup inf_comp sup_comp neg_assume_def sup_inf_distrib2)
  apply (simp add: dual_inf sup_comp neg_assume_def sup.assoc)
  by (simp add: dual_comp dual_sup inf_comp neg_assume_def)

sublocale mbt_algebra < mbta: relative_domain_semiring_split where d = "λx . (x * top)  1" and Z = bot
  apply unfold_locales
  by simp

sublocale mbt_algebra < mbta_dual: relative_domain_semiring_split where d = "λx . (x * bot)  1" and less = greater and less_eq = greater_eq and sup = inf and bot = top and Z = top
  apply unfold_locales
  by simp

sublocale mbt_algebra < mbta: diamond_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Z = bot
  apply unfold_locales
  apply simp
  apply simp
  apply (rule wpt_def)
  apply simp
  by simp

sublocale mbt_algebra < mbta_dual: box_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  apply simp
  apply simp
  apply (metis assume_bot dual_comp mbta_dual.a_mult_d_2 mbta_dual.d_def neg_assume_def wpb_def mult_assoc)
  apply simp
  by simp

sublocale mbt_algebra < mbta_fix: diamond_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Z = bot
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_fix_dual: box_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_pre: box_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Z = bot
  apply unfold_locales
  apply (metis dual_comp dual_dual dual_top inf_top_right mbta_dual.mult_right_dist_sup mult_1_left neg_assert_def top_comp wpt_def mult_assoc)
  apply simp
  by simp

sublocale mbt_algebra < mbta_pre_dual: diamond_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  apply (simp add: wpb_def)
  apply simp
  by simp

sublocale mbt_algebra < mbta_pre_fix: box_while where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Z = bot
  apply unfold_locales
  by simp_all

sublocale mbt_algebra < mbta_pre_fix_dual: diamond_while where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot and Z = top
  apply unfold_locales
  by simp_all

sublocale post_mbt_algebra < mbta: pre_post_spec_Hd where box = "λx y . neg_assert (x * neg_assert y)" and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and pre = "λx y . wpt (x * y)" and pre_post = "λp q . p * post q" and uminus = neg_assert and Hd = "post 1" and Z = bot
  apply unfold_locales
  apply (metis mult.assoc mult.left_neutral post_1)
  apply (metis inf.commute inf_top_right mult.assoc mult.left_neutral post_2)
  apply (metis neg_assertion assertion_disjunctive disjunctiveD)
  subgoal for p x q
  proof
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume "?pt  wpt (x * ?qt)"
    hence "?pt * post ?qt  x * ?qt * top * post ?qt  post ?qt"
      by (metis mbta.mult_left_isotone wpt_def inf_comp mult.left_neutral)
    thus "?pt * post ?qt  x"
      by (smt mbta.top_left_zero mult.assoc post_2 order_trans)
  next
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume "?pt * post ?qt  x"
    thus "?pt  wpt (x * ?qt)"
      by (smt mbta.a_d_closed post_1 mult_assoc mbta.diamond_left_isotone wpt_def)
  qed
  by (simp add: mbta_dual.mult_right_dist_sup)

sublocale post_mbt_algebra < mbta_dual: pre_post_spec_H where box = "λx y . neg_assume (x * neg_assume y)" and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and bot = top and H = "post 1" and top = bot and Z = top
proof
  fix p x q
  let ?pt = "neg_assume p"
  let ?qt = "neg_assume q"
  show "wpb (x ^ o * ?qt)  ?pt  ?pt ^ o * post (?qt ^ o)  x"
  proof
    assume "wpb (x ^ o * ?qt)  ?pt"
    hence "?pt ^ o * post (?qt ^ o)  (x * (?qt ^ o) * top  1) * post (?qt ^ o)"
      by (smt wpb_def dual_le dual_comp dual_dual dual_one dual_sup dual_top mbta.mult_left_isotone)
    thus "?pt ^ o * post (?qt ^ o)  x"
      by (smt inf_comp mult_assoc top_comp mult.left_neutral post_2 order_trans)
  next
    assume 1: "?pt ^ o * post (?qt ^ o)  x"
    have "?pt ^ o = ?pt ^ o * post (?qt ^ o) * (?qt ^ o) * top  1"
      by (metis assert_iff_assume assertion_prop dual_dual mult_assoc neg_assumption post_1)
    thus "wpb (x ^ o * ?qt)  ?pt"
      using 1 by (smt dual_comp dual_dual dual_le dual_one dual_sup dual_top wpb_def mbta.diamond_left_isotone)
  qed
  show "post 1 * top = top"
    by (simp add: mbta.Hd_total)
  have "x * ?qt * bot  (post 1 * neg_assume ?qt) = (x * neg_assume ?qt ^ o * top  post 1) * neg_assume ?qt"
    by (simp add: assume_bot mbta_dual.mult_right_dist_sup mult_assoc)
  also have "...  x * neg_assume ?qt ^ o"
    by (smt assumption_assertion_absorb dual_comp dual_dual mbta.mult_left_isotone mult.right_neutral mult_assoc neg_assumption post_2)
  also have "...  x"
    by (metis dual_comp dual_dual dual_le mbta.mult_left_sub_dist_sup_left mult.right_neutral neg_assume_def sup.commute)
  finally show "x * ?qt * bot  (post 1 * neg_assume ?qt)  x"
    .
qed

sublocale post_mbt_algebra < mbta_pre: pre_post_spec_H where box = "λx y . neg_assert (x * neg_assert y)" and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and H = "post 1 ^ o" and Z = bot
proof
  fix p x q
  let ?pt = "neg_assert p"
  let ?qt = "neg_assert q"
  show "?pt  wpt (x ^ o * ?qt)  x  ?pt ^ o * (post ?qt ^ o)"
  proof
    assume "?pt  wpt (x ^ o * ?qt)"
    hence "?pt * post ?qt  (x ^ o * ?qt * top  1) * post ?qt"
      by (simp add: mbta_dual.mult_left_isotone wpt_def)
    also have "...  x ^ o"
      using mbta.pre_pre_post wpt_def by auto
    finally show "x  ?pt ^ o * (post ?qt ^ o)"
      by (metis dual_le dual_comp dual_dual)
  next
    assume "x  ?pt ^ o * (post ?qt ^ o)"
    hence "x * ?qt ^ o * bot  1  (?pt * post ?qt * ?qt * top  1) ^ o"
      by (smt (z3) inf.absorb_iff1 sup_inf_distrib2 dual_comp dual_inf dual_one dual_top mbta.mult_left_isotone)
    also have "... = ?pt ^ o"
      by (simp add: mbta.diamond_a_export post_1)
    finally show "?pt  wpt (x ^ o * ?qt)"
      by (smt dual_comp dual_dual dual_le dual_neg_top dual_one dual_sup dual_top wpt_def)
  qed
  show "post 1 ^ o * bot = bot"
    by (metis dual_comp dual_top mbta.Hd_total)
  have "x ^ o * ?qt ^ o * bot  (post 1 * neg_assert ?qt ^ o)  x ^ o * neg_assert ?qt * neg_assert ?qt ^ o"
    by (smt (verit, del_insts) bot_comp inf.commute inf_comp inf_top_left mbta.mult_left_isotone mult.left_neutral mult_assoc neg_assert_def post_2)
  also have "...  x ^ o"
    by (smt assert_iff_assume assumption_assertion_absorb dual_comp dual_dual le_comp mbta.a_below_one mult_assoc neg_assertion mult_1_right)
  finally show "x  x * ?qt * top  post 1 ^ o * neg_assert ?qt"
    by (smt dual_comp dual_dual dual_inf dual_le dual_top)
qed

sublocale post_mbt_algebra < mbta_pre_dual: pre_post_spec_Hd where box = "λx y . neg_assume (x * neg_assume y)" and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and pre_post = "λp q . p * (post (q ^ o) ^ o)" and uminus = neg_assume and bot = top and Hd = "post 1 ^ o" and top = bot and Z = top
  apply unfold_locales
  apply (simp add: mbta_pre.H_zero_2)
  apply (simp add: mbta_pre.H_greatest_finite)
  apply (metis (no_types, lifting) dual_comp dual_dual dual_inf dual_top mbta_dual.mult_L_circ_mult mult_1_right neg_assume_def sup_commute sup_inf_distrib2)
  subgoal for p x q
  proof
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "wpb (x * ?qt)  ?pt"
    hence "?pt ^ o * post (?qt ^ o)  (x ^ o * ?qt ^ o * top  1) * post (?qt ^ o)"
      by (smt dual_comp dual_dual dual_le dual_one dual_sup dual_top le_comp_right wpb_def)
    also have "...  x ^ o"
      using mbta_dual.mult_right_dist_sup post_2 by force
    finally show "x  ?pt * post (?qt ^ o) ^ o"
      by (smt dual_comp dual_dual dual_le)
  next
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "x  ?pt * post (?qt ^ o) ^ o"
    thus "wpb (x * ?qt)  ?pt"
      by (metis dual_comp dual_dual dual_le mbta_dual.pre_post_galois)
  qed
  by (simp add: sup_comp)

sublocale post_mbt_algebra < mbta_dual: pre_post_spec_whiledo where ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and top = bot ..

sublocale post_mbt_algebra < mbta_fix_dual: pre_post_spec_whiledo where ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and top = bot ..

sublocale post_mbt_algebra < mbta_pre: pre_post_spec_whiledo where ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" ..

sublocale post_mbt_algebra < mbta_pre_fix: pre_post_spec_whiledo where ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" ..

sublocale post_mbt_algebra < mbta_dual: pre_post_L where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and L = bot and top = bot and Z = top
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_fix_dual: pre_post_L where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and L = top and top = bot and Z = top
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_pre: pre_post_L where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and L = bot and Z = bot
  apply unfold_locales
  by simp

sublocale post_mbt_algebra < mbta_pre_fix: pre_post_L where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and L = top and Z = bot
  apply unfold_locales
  by simp

sublocale complete_mbt_algebra < mbta: complete_tests where uminus = neg_assert
  apply unfold_locales
  apply (smt mbta.test_set_def neg_assertion subset_eq Sup_assertion assertion_neg_assert)
  apply (simp add: Sup_upper)
  by (simp add: Sup_least)

sublocale complete_mbt_algebra < mbta_dual: complete_tests where less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and Inf = Sup and Sup = Inf
  apply unfold_locales
  apply (smt mbta_dual.test_set_def neg_assumption subset_eq Inf_assumption assumption_neg_assume)
  apply (simp add: Inf_lower)
  by (simp add: Inf_greatest)

sublocale complete_mbt_algebra < mbta: complete_antidomain_semiring where d = "λx . (x * top)  1" and uminus = neg_assert and Z = bot
proof
  fix f :: "nat  'a"
  let ?F = "dual ` {f n | n . True}"
  show "ascending_chain f  neg_assert (complete_tests.Sum Sup f) = complete_tests.Prod Inf (λn. neg_assert (f n))"
  proof
    have "neg_assert (complete_tests.Sum Sup f) = 1  (x?F . x * bot)"
      using Inf_comp dual_Sup mbta.Sum_def neg_assert_def inf_commute by auto
    also have "... = (x?F . 1  x * bot)"
      apply (subst inf_Inf)
      apply blast
      by (simp add: image_image)
    also have "... = {f n ^ o * bot  1 | n . True}"
      apply (rule arg_cong[where f="Inf"])
      using inf_commute by auto
    also have "... = complete_tests.Prod Inf (λn. neg_assert (f n))"
      using mbta.Prod_def neg_assert_def by auto
    finally show "neg_assert (complete_tests.Sum Sup f) = complete_tests.Prod Inf (λn. neg_assert (f n))"
      .
  qed
  show "descending_chain f  neg_assert (complete_tests.Prod Inf f) = complete_tests.Sum Sup (λn. neg_assert (f n))"
  proof
    have "neg_assert (complete_tests.Prod Inf f) = 1  (x?F . x * bot)"
      using Sup_comp dual_Inf mbta.Prod_def neg_assert_def inf_commute by auto
    also have "... = (x?F . 1  x * bot)"
      by (simp add: inf_Sup image_image)
    also have "... = {f n ^ o * bot  1 |n. True}"
      apply (rule arg_cong[where f="Sup"])
      using inf_commute by auto
    also have "... = complete_tests.Sum Sup (λn. neg_assert (f n))"
      using mbta.Sum_def neg_assert_def by auto
    finally show "neg_assert (complete_tests.Prod Inf f) = complete_tests.Sum Sup (λn. neg_assert (f n))"
      .
  qed
qed

sublocale complete_mbt_algebra < mbta_dual: complete_antidomain_semiring where d = "λx . (x * bot)  1" and less = greater and less_eq = greater_eq and sup = inf and uminus = neg_assume and bot = top and Inf = Sup and Sup = Inf and Z = top
proof
  fix f :: "nat  'a"
  let ?F = "dual ` {f n | n . True}"
  show "ord.ascending_chain greater_eq f  neg_assume (complete_tests.Sum Inf f) = complete_tests.Prod Sup (λn. neg_assume (f n))"
  proof
    have "neg_assume (complete_tests.Sum Inf f) = 1  (x?F . x * top)"
      using mbta_dual.Sum_def neg_assume_def dual_Inf Sup_comp sup_commute by auto
    also have "... = (x?F . 1  x * top)"
      apply (subst sup_Sup)
      apply blast
      by (simp add: image_image)
    also have "... = {f n ^ o * top  1 | n . True}"
      apply (rule arg_cong[where f="Sup"])
      using sup_commute by auto
    also have "... = complete_tests.Prod Sup (λn. neg_assume (f n))"
      using mbta_dual.Prod_def neg_assume_def by auto
    finally show "neg_assume (complete_tests.Sum Inf f) = complete_tests.Prod Sup (λn. neg_assume (f n))"
      .
  qed
  show "ord.descending_chain greater_eq f  neg_assume (complete_tests.Prod Sup f) = complete_tests.Sum Inf (λn. neg_assume (f n))"
  proof
    have "neg_assume (complete_tests.Prod Sup f) = 1  (x?F . x * top)"
      using mbta_dual.Prod_def neg_assume_def dual_Inf dual_Sup Inf_comp sup_commute by auto
    also have "... = (x?F . 1  x * top)"
      by (simp add: sup_Inf image_image)
    also have "... = {f n ^ o * top  1 |n. True}"
      apply (rule arg_cong[where f="Inf"])
      using sup_commute by auto
    also have "... = complete_tests.Sum Inf (λn. neg_assume (f n))"
      using mbta_dual.Sum_def neg_assume_def by auto
    finally show "neg_assume (complete_tests.Prod Sup f) = complete_tests.Sum Inf (λn. neg_assume (f n))"
      .
  qed
qed

sublocale complete_mbt_algebra < mbta: diamond_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: one_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_dual: box_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and top = bot and Z = top
  apply unfold_locales
  apply (simp add: one_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_fix: diamond_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: one_co_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_fix_dual: box_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and top = bot and Z = top
  apply unfold_locales
  apply (simp add: one_co_continuous)
  by simp_all

sublocale complete_mbt_algebra < mbta_pre: box_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot ..

sublocale complete_mbt_algebra < mbta_pre_dual: diamond_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and top = bot and Z = top ..

sublocale complete_mbt_algebra < mbta_pre_fix: box_while_program where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot ..

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_while_program where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and top = bot and Z = top ..

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta: diamond_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  by (simp add: mbta.aL_one_circ mbta.star_one)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_dual: box_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  using mbta.top_greatest mbta.vector_bot_closed mbta_dual.aL_one_circ mbta_dual.a_top omega_one top_comp by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_fix: diamond_hoare_sound_2 where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
proof (unfold_locales, rule impI)
  fix p q x
  let ?pt = "neg_assert p"
  let ?qt = "neg_assert q"
  assume "neg_assert ?pt * ?qt  x * ?qt * top  1"
  hence "?qt * top  x ^  * ?pt * top"
    by (smt mbta.Omega_induct mbta.d_def mbta.d_mult_top mbta.mult_left_isotone mbta.shunting_top_1 mult.assoc)
  thus "mbta_fix.aL * ?qt  x ^  * ?pt * top  1"
    by (smt (z3) inf.absorb_iff1 inf.sup_monoid.add_commute inf_comp inf_le2 inf_left_commute inf_top_left mbta_fix.aL_one_circ mbta_pre_dual.top_left_zero mult_1_left neg_assert_def mult.assoc)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_fix_dual: box_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  by (simp add: mbta_dual.star_one mbta_fix_dual.aL_one_circ)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre: box_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  using mbta.star_one mbta_pre.aL_one_circ by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_dual: diamond_hoare_sound_2 where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
proof (unfold_locales, rule impI)
  fix p q x
  let ?pt = "neg_assume p"
  let ?qt = "neg_assume q"
  assume "x * ?qt * bot  1  neg_assume ?pt * ?qt"
  hence "x * ?qt * bot  ?pt  ?qt"
    by (smt (z3) inf.absorb_iff1 inf_left_commute inf_commute inf_le1 le_supE mbta_dual.a_compl_intro mbta_dual.d_def order_trans)
  hence "(x * ?qt * bot  ?pt) * bot  ?qt * bot"
    using mbta.mult_left_isotone by blast
  hence "x ^ ω * ?pt * bot  1  ?qt"
    by (smt bot_comp inf_comp sup_left_isotone mbta_dual.a_d_closed mult_assoc omega_least)
  thus "x ^ ω * ?pt * bot  1  mbta_pre_dual.aL * ?qt"
    by (simp add: mbta_pre_dual.aL_one_circ)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix: box_hoare_sound where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  using mbta.Omega_one mbta_pre_fix.aL_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_hoare_sound where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  by (simp add: mbta_dual.star_one mbta_pre_fix_dual.aL_one_circ)

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta: diamond_hoare_valid where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_star and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and hoare_triple = "λp x q . p  wpt(x * q)" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion and Z = bot
  apply unfold_locales
  apply (simp add: mbta.aL_zero)
  using mbta.aL_zero apply blast
  subgoal for x t
  proof
    assume 1: "x  while_program.While_program (*) neg_assert Continuous assertion (λp x . (p * x) ^  * neg_assert p) (λx p y . p * x  neg_assert p * y)  ascending_chain t  tests.test_seq neg_assert t"
    have "x  Continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpt (x * y)" and while="λp x . ((p * x) ^ ) * neg_assert p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      using mult_continuous apply blast
      apply (metis assertion_continuous mbta.test_expression_test mult_continuous neg_assertion sup_continuous)
      by (metis assertion_continuous dual_star_continuous mbta.test_expression_test mult_continuous neg_assertion)
    thus "x * complete_tests.Sum Sup t = complete_tests.Sum Sup (λn. x * t n)"
      using 1 by (smt continuous_dist_ascending_chain SUP_cong mbta.Sum_range)
  qed
  using wpt_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_dual: box_hoare_valid where box = "λx y . neg_assume (x * neg_assume y)" and circ = omega and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and hoare_triple = "λp x q . wpb(x ^ o * q)  p" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
proof
  fix p x q t
  show "neg_assume q  neg_assume p * neg_assume (x * neg_assume (neg_assume q))  neg_assume q  whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1  neg_assume (x ^ ω * neg_assume (neg_assume p))"
  proof
    let ?pt = "neg_assume p"
    let ?qt = "neg_assume q"
    assume "?qt  ?pt * neg_assume (x * neg_assume ?qt)"
    also have "...  x ^ o * ?qt  ?pt"
      by (smt assumption_sup_comp_eq sup_left_isotone mbta.zero_right_mult_decreasing mbta_dual.pre_def neg_assume_def neg_assumption sup.commute sup.left_commute sup.left_idem wpb_def)
    finally show "?qt  mbta_dual.aL  neg_assume (x ^ ω * neg_assume ?pt)"
      by (smt dual_dual dual_omega_def dual_omega_greatest le_infI1 mbta_dual.a_d_closed mbta_dual.d_isotone mbta_dual.pre_def wpb_def)
  qed
  show "whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1 = top  whiledo.aL (λp x. (p * x) ^ ω * neg_assume p) (λx y. wpb (x ^ o * y)) 1 = 1"
    using mbta_dual.L_def mbta_dual.aL_one_circ mbta_dual.a_top by auto
  show "x  while_program.While_program (*) neg_assume Continuous assumption (λp x. (p * x) ^ ω * neg_assume p) (λx p y. p * x  neg_assume p * y)  ord.descending_chain (λx y. y  x) t  tests.test_seq neg_assume t  x * complete_tests.Prod Sup t = complete_tests.Prod Sup (λn. x * t n)"
  proof
    assume 1: "x  while_program.While_program (*) neg_assume Continuous assumption (λp x . (p * x) ^ ω * neg_assume p) (λx p y . (p * x)  (neg_assume p * y))  ord.descending_chain greater_eq t  tests.test_seq neg_assume t"
    have "x  Continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpb (x ^ o * y)" and while="λp x . ((p * x) ^ ω) * neg_assume p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_continuous)
      apply (metis assumption_continuous mbta_dual.test_expression_test mult_continuous neg_assumption inf_continuous)
      by (metis assumption_continuous omega_continuous mbta_dual.test_expression_test mult_continuous neg_assumption)
    thus "x * complete_tests.Prod Sup t = complete_tests.Prod Sup (λn. x * t n)"
      using 1 by (smt ord.descending_chain_def ascending_chain_def continuous_dist_ascending_chain SUP_cong mbta_dual.Prod_range)
  qed
  show "(wpb (x ^ o * q)  p) = (neg_assume (x * neg_assume q)  p)"
    by (simp add: mbta_dual.pre_def)
qed

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix_dual: diamond_hoare_valid where box = "λx y . neg_assume (x * neg_assume y)" and circ = star and d = "λx . (x * bot)  1" and diamond = "λx y . (x * y * bot)  1" and hoare_triple = "λp x q . wpb(x * q)  p" and ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x * y)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot and Z = top
  apply unfold_locales
  using mbta_dual.star_one mbta_pre_fix_dual.aL_one_circ apply simp
  using mbta_pre_fix_dual.aL_zero apply blast
  subgoal for x t
  proof
    assume 1: "x  while_program.While_program (*) neg_assume Co_continuous assumption (λp x . (p * x) ^ * * neg_assume p) (λx p y . (p * x)  (neg_assume p * y))  ord.ascending_chain greater_eq t  tests.test_seq neg_assume t"
    have "x  Co_continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpb (x * y)" and while="λp x . ((p * x) ^ * ) * neg_assume p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_co_continuous)
      apply (metis assumption_co_continuous mbta_dual.test_expression_test mult_co_continuous neg_assumption inf_co_continuous)
      by (metis assumption_co_continuous star_co_continuous mbta_dual.test_expression_test mult_co_continuous neg_assumption)
    thus "x * complete_tests.Sum Inf t = complete_tests.Sum Inf (λn. x * t n)"
      using 1 by (smt descending_chain_def ord.ascending_chain_def co_continuous_dist_descending_chain INF_cong mbta_dual.Sum_range)
  qed
  using wpb_def by auto

text ‹Theorem 52›

sublocale complete_mbt_algebra < mbta_pre_fix: box_hoare_valid where box = "λx y . neg_assert (x * neg_assert y)" and circ = dual_omega and d = "λx . (x * top)  1" and diamond = "λx y . (x * y * top)  1" and hoare_triple = "λp x q . p  wpt(x ^ o * q)" and ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and star = dual_star and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion and Z = bot
proof
  fix p x q t
  show "neg_assert p * neg_assert (x * neg_assert (neg_assert q))  neg_assert q  neg_assert (x ^  * neg_assert (neg_assert p))  neg_assert q  whiledo.aL (λp x. (p * x) ^  * neg_assert p) (λx y. wpt (x ^ o * y)) 1"
  proof
    let ?pt = "neg_assert p"
    let ?qt = "neg_assert q"
    assume 1: "?pt * neg_assert (x * neg_assert ?qt)  ?qt"
    have "x ^ o * ?qt  ?pt  ?pt * neg_assert (x * neg_assert ?qt)"
      by (smt (z3) inf.boundedI inf.cobounded1 inf.sup_monoid.add_commute le_infI2 inf_comp mbta.tests_dual.sub_commutative mbta.top_right_mult_increasing mbta_pre.pre_def mult.left_neutral mult_assoc top_comp wpt_def)
    also have "...  ?qt"
      using 1 by simp
    finally have "(x ^ o) ^ ω * ?pt * top  ?qt * top"
      using mbta.mult_left_isotone omega_least by blast
    hence "neg_assert (x ^  * neg_assert ?pt)  ?qt"
      by (smt dual_omega_def inf_mono mbta.d_a_closed mbta.d_def mbta_pre.pre_def order_refl wpt_def mbta.a_d_closed)
    thus "neg_assert (x ^  * neg_assert ?pt)  ?qt  mbta_pre_fix.aL"
      using le_supI1 by blast
  qed
  show "whiledo.aL (λp x. (p * x) ^  * neg_assert p) (λx y. wpt (x ^ o * y)) 1 = bot  whiledo.aL (λp x. (p * x) ^  * neg_assert p) (λx y. wpt (x ^ o * y)) 1 = 1"
    using mbta.Omega_one mbta.a_top mbta_dual.vector_bot_closed mbta_pre_fix.aL_one_circ by auto
  show "x  while_program.While_program (*) neg_assert Co_continuous assertion (λp x. (p * x) ^  * neg_assert p) (λx p y. p * x  neg_assert p * y)  descending_chain t  tests.test_seq neg_assert t  x * complete_tests.Prod Inf t = complete_tests.Prod Inf (λn. x * t n)"
  proof
    assume 1: "x  while_program.While_program (*) neg_assert Co_continuous assertion (λp x . (p * x) ^  * neg_assert p) (λx p y . p * x  neg_assert p * y)  descending_chain t  tests.test_seq neg_assert t"
    have "x  Co_continuous"
      apply (induct x rule: while_program.While_program.induct[where pre="λx y . wpt (x ^ o * y)" and while="λp x . ((p * x) ^ ) * neg_assert p"])
      apply unfold_locales
      using 1 apply blast
      apply simp
      apply (simp add: mult_co_continuous)
      apply (metis assertion_co_continuous mbta.test_expression_test mult_co_continuous neg_assertion sup_co_continuous)
      by (metis assertion_co_continuous dual_omega_co_continuous mbta.test_expression_test mult_co_continuous neg_assertion)
    thus "x * complete_tests.Prod Inf t = complete_tests.Prod Inf (λn. x * t n)"
      using 1 by (smt descending_chain_def co_continuous_dist_descending_chain INF_cong mbta.Prod_range)
  qed
  show "(p  wpt (x ^ o * q)) = (p  neg_assert (x * neg_assert q))"
    by (simp add: mbta_pre.pre_def)
qed

sublocale complete_mbt_algebra < mbta_dual: pre_post_spec_hoare where ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ ω) * neg_assume p" and bot = top and Atomic_program = Continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot ..

sublocale complete_mbt_algebra < mbta_fix_dual: pre_post_spec_hoare where ite = "λx p y . (p * x)  (neg_assume p * y)" and less = greater and less_eq = greater_eq and sup = inf and pre = "λx y . wpb (x ^ o * y)" and pre_post = "λp q . (p ^ o) * post (q ^ o)" and uminus = neg_assume and while = "λp x . ((p * x) ^ *) * neg_assume p" and bot = top and Atomic_program = Co_continuous and Atomic_test = assumption and Inf = Sup and Sup = Inf and top = bot ..

sublocale complete_mbt_algebra < mbta_pre: pre_post_spec_hoare where ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Continuous and Atomic_test = assertion ..

sublocale complete_mbt_algebra < mbta_pre_fix: pre_post_spec_hoare where ite = "λx p y . (p * x)  (neg_assert p * y)" and pre = "λx y . wpt (x ^ o * y)" and pre_post = "λp q . p ^ o * (post q ^ o)" and uminus = neg_assert and while = "λp x . ((p * x) ^ ) * neg_assert p" and Atomic_program = Co_continuous and Atomic_test = assertion ..

end